[Tkabber-dev] r1156 - in trunk/tkabber: . doc ifacetk jabberlib-tclxml

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sun Jul 15 17:53:37 MSD 2007


Author: sergei
Date: 2007-07-15 17:53:33 +0400 (Sun, 15 Jul 2007)
New Revision: 1156

Added:
   trunk/tkabber/jabberlib-tclxml/autoconnect.tcl
   trunk/tkabber/jabberlib-tclxml/https.tcl
   trunk/tkabber/jabberlib-tclxml/socks4.tcl
   trunk/tkabber/jabberlib-tclxml/socks5.tcl
Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/README
   trunk/tkabber/doc/tkabber.html
   trunk/tkabber/doc/tkabber.xml
   trunk/tkabber/ifacetk/ilogin.tcl
   trunk/tkabber/jabberlib-tclxml/jabberlib.tcl
   trunk/tkabber/jabberlib-tclxml/ntlm.tcl
   trunk/tkabber/jabberlib-tclxml/pkgIndex.tcl
   trunk/tkabber/jabberlib-tclxml/transports.tcl
   trunk/tkabber/login.tcl
Log:
	* jabberlib-tclxml/ntlm.tcl: Wrapped md5::md5 procedure to make
	  possible using md5 package earlier than 2.0.

	* jabberlib-tclxml/transports.tcl, jabberlib-tclxml/https.tcl: Moved
	  HTTPS proxy support to a separate https package.

	* jabberlib-tclxml/socks4.tcl, jabberlib-tclxml/socks5.tcl: Added
	  SOCKS4a and SOCKS5 proxy support (the code is mostly borrowed from
	  Mats Bengtsson).

	* jabberlib-tclxml/autoconnect.tcl: Added a wrapper over the socket
	  command, which allows to connect via proxy.

	* jabberlib-tclxml/jabberlib.tcl, jabberlib-tclxml/transports.tcl:
	  Made use of socks4, socks5 and https packages. Unfinished yet, todo
	  meaningful error messages.

	* login.tcl, ifacetk/ilogin.tcl: Added support for new proxy types.
	  Changed binary loginconf(useproxy) to loginconf(proxy) with values
	  none, socks4, socks5, https. Changed loginconf(httpproxy) to
	  loginconf(proxyhost), loginconf(httpport) to loginconf(proxyport),
	  loginconf(httplogin) to loginconf(proxyusername) and
	  loginconf(httppassword) to loginconf(proxypassword) option names.

	* doc/tkabber.xml, doc/tkabber.html, README: Documented changes in
	  options.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/ChangeLog	2007-07-15 13:53:33 UTC (rev 1156)
@@ -1,3 +1,32 @@
+2007-07-15  Sergei Golovan  <sgolovan at nes.ru>
+
+	* jabberlib-tclxml/ntlm.tcl: Wrapped md5::md5 procedure to make
+	  possible using md5 package earlier than 2.0.
+
+	* jabberlib-tclxml/transports.tcl, jabberlib-tclxml/https.tcl: Moved
+	  HTTPS proxy support to a separate https package.
+
+	* jabberlib-tclxml/socks4.tcl, jabberlib-tclxml/socks5.tcl: Added
+	  SOCKS4a and SOCKS5 proxy support (the code is mostly borrowed from
+	  Mats Bengtsson).
+
+	* jabberlib-tclxml/autoconnect.tcl: Added a wrapper over the socket
+	  command, which allows to connect via proxy.
+
+	* jabberlib-tclxml/jabberlib.tcl, jabberlib-tclxml/transports.tcl:
+	  Made use of socks4, socks5 and https packages. Unfinished yet, todo
+	  meaningful error messages.
+
+	* login.tcl, ifacetk/ilogin.tcl: Added support for new proxy types.
+	  Changed binary loginconf(useproxy) to loginconf(proxy) with values
+	  none, socks4, socks5, https. Changed loginconf(httpproxy) to
+	  loginconf(proxyhost), loginconf(httpport) to loginconf(proxyport),
+	  loginconf(httplogin) to loginconf(proxyusername) and
+	  loginconf(httppassword) to loginconf(proxypassword) option names.
+
+	* doc/tkabber.xml, doc/tkabber.html, README: Documented changes in
+	  options.
+
 2007-07-12  Sergei Golovan  <sgolovan at nes.ru>
 
 	* jabberlib-tclxml/wrapper.tcl: Do not add xmlns attribute to an XML

Modified: trunk/tkabber/README
===================================================================
--- trunk/tkabber/README	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/README	2007-07-15 13:53:33 UTC (rev 1156)
@@ -205,7 +205,7 @@
 
       *  compressed sessions (if you install an optional extension)
 
-      *  login via HTTP proxy
+      *  login via SOCKS4a, SOCKS5 or HTTPS proxy
 
       *  user-defined hooks for connection establishment and release
 
@@ -1202,13 +1202,13 @@
        set loginconf(altserver)      ""
        set loginconf(altport)        5422
        set loginconf(stream_options) plaintext
-       set loginconf(useproxy)       0
+       set loginconf(proxy)          https
        set loginconf(usesasl)        1
        set loginconf(allowauthplain) 0
-       set loginconf(httpproxy)      localhost
-       set loginconf(httpproxyport)  3128
-       set loginconf(httplogin)     ""
-       set loginconf(httppassword)  ""
+       set loginconf(proxyhost)      localhost
+       set loginconf(proxyport)      3128
+       set loginconf(proxyusername)  ""
+       set loginconf(proxypassword)  ""
 
        # The following variables are useful when your jabber-server
        # (example.com) does not have SRV or A-record in DNS

Modified: trunk/tkabber/doc/tkabber.html
===================================================================
--- trunk/tkabber/doc/tkabber.html	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/doc/tkabber.html	2007-07-15 13:53:33 UTC (rev 1156)
@@ -1,6 +1,6 @@
 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
 <html lang="en"><head><title>Tkabber v0.10.0</title>
-<meta http-equiv="Expires" content="Thu, 17 May 2007 17:12:32 +0000">
+<meta http-equiv="Expires" content="Sun, 15 Jul 2007 13:07:28 +0000">
 <meta http-equiv="Content-Type" content="text/html; charset=utf-8">
 <meta name="description" content="Tkabber v0.10.0">
 <meta name="generator" content="xml2rfc v1.30 (http://xml.resource.org/)">
@@ -327,7 +327,7 @@
 </li>
 <li>compressed sessions (if you install an optional extension)
 </li>
-<li>login via HTTP proxy
+<li>login via SOCKS4a, SOCKS5 or HTTPS proxy
 </li>
 <li>
 		user-defined hooks for connection establishment and
@@ -1218,13 +1218,13 @@
     set loginconf(altserver)      ""
     set loginconf(altport)        5422
     set loginconf(stream_options) plaintext
-    set loginconf(useproxy)       0
+    set loginconf(proxy)          https
     set loginconf(usesasl)        1
     set loginconf(allowauthplain) 0
-    set loginconf(httpproxy)      localhost
-    set loginconf(httpproxyport)  3128
-    set loginconf(httplogin)     ""
-    set loginconf(httppassword)  ""
+    set loginconf(proxyhost)      localhost
+    set loginconf(proxyport)      3128
+    set loginconf(proxyusername)  ""
+    set loginconf(proxypassword)  ""
 
     # The following variables are useful when your jabber-server
     # (example.com) does not have SRV or A-record in DNS

Modified: trunk/tkabber/doc/tkabber.xml
===================================================================
--- trunk/tkabber/doc/tkabber.xml	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/doc/tkabber.xml	2007-07-15 13:53:33 UTC (rev 1156)
@@ -96,7 +96,7 @@
 	      <t>SASL authentication</t>
 	      <t>encrypted sessions (if you install an optional extension)</t>
 	      <t>compressed sessions (if you install an optional extension)</t>
-	      <t>login via HTTP proxy</t>
+	      <t>login via SOCKS4a, SOCKS5 or HTTPS proxy</t>
 	      <t>
 		user-defined hooks for connection establishment and
 		release
@@ -924,13 +924,13 @@
     set loginconf(altserver)      ""
     set loginconf(altport)        5422
     set loginconf(stream_options) plaintext
-    set loginconf(useproxy)       0
+    set loginconf(proxy)          https
     set loginconf(usesasl)        1
     set loginconf(allowauthplain) 0
-    set loginconf(httpproxy)      localhost
-    set loginconf(httpproxyport)  3128
-    set loginconf(httplogin)     ""
-    set loginconf(httppassword)  ""
+    set loginconf(proxyhost)      localhost
+    set loginconf(proxyport)      3128
+    set loginconf(proxyusername)  ""
+    set loginconf(proxypassword)  ""
 
     # The following variables are useful when your jabber-server
     # (example.com) does not have SRV or A-record in DNS

Modified: trunk/tkabber/ifacetk/ilogin.tcl
===================================================================
--- trunk/tkabber/ifacetk/ilogin.tcl	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/ifacetk/ilogin.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -8,7 +8,7 @@
 	array set loginconf [array get ltmp]
     }
     foreach ent {username server port password resource priority \
-            altserver httpproxy httpproxyport httplogin httppassword \
+            altserver proxyhost proxyport proxyusername proxypassword \
             sslcertfile pollurl} {
         if {[winfo exists $l.$ent]} {
             catch { $l.$ent icursor end }
@@ -19,8 +19,6 @@
 			{dontusessl usecompress legacyssl encrypted \
 			 sslcertfile lsslcertfile bsslcertfile} \
             usealtserver {altserver laltserver port lport} {} \
-            useproxy {httpproxy httpproxyport httplogin httppassword \
-            lhttpproxy lhttpproxyport lhttplogin lhttppassword} {} \
 	    } {
         if {![info exists ltmp($check)] || ![winfo exists $l.$check]} {
             continue
@@ -51,6 +49,22 @@
 	}
     }
     catch {
+	if {[cequal $ltmp(proxy) none]} {
+	    foreach ent {proxyhost proxyport proxyusername proxypassword \
+			 lproxyhost lproxyport lproxyusername lproxypassword} {
+		$l.$ent configure -state disabled
+                if {[cequal [focus] $l.$ent]} {
+                    focus [Widget::focusPrev $l.$ent]
+                }
+	    }
+	} else {
+	    foreach ent {proxyhost proxyport proxyusername proxypassword \
+			 lproxyhost lproxyport lproxyusername lproxypassword} {
+		$l.$ent configure -state normal
+	    }
+	}
+    }
+    catch {
 	if {![cequal [$l.dontusessl cget -state] disabled] && \
 		($ltmp(stream_options) == "ssl" || \
 		 $ltmp(stream_options) == "encrypted")} {
@@ -217,7 +231,7 @@
 	    radiobutton $l.legacyssl -text [::msgcat::mc "Encryption (legacy SSL)"] \
 		-variable ltmp(stream_options) -value ssl \
 		-command [list [namespace current]::update_login_entries $l]
-	    label $l.lsslcertfile -text [::msgcat::mc "SSL Certificate:"]
+	    label $l.lsslcertfile -text [::msgcat::mc "SSL certificate:"]
 	    entry $l.sslcertfile -textvariable ltmp(sslcertfile)
 	    button $l.bsslcertfile -text [::msgcat::mc "Browse..."] \
 		-command [list eval set ltmp(sslcertfile) {[tk_getOpenFile]}]
@@ -266,31 +280,61 @@
     if {$have_proxy} {
 	set proxy_page [$nb insert end proxy_page -text [::msgcat::mc "Proxy"]]
 
-	checkbutton $l.useproxy -text [::msgcat::mc "Use Proxy"] \
-	    -variable ltmp(useproxy) \
-	    -command [list [namespace current]::update_login_entries $l]
-	grid $l.useproxy -row 0 -column 0 -sticky w -columnspan 3 -in $proxy_page
+	label $l.lproxy -text [::msgcat::mc "Proxy type:"]
+	grid $l.lproxy -row 0 -column 0 -sticky e -in $proxy_page
+	frame $l.proxy
+	grid $l.proxy -row 0 -column 1 -columnspan 3 -sticky w -in $proxy_page
 
-	label $l.lhttpproxy -text [::msgcat::mc "Proxy Server:"]
-	entry $l.httpproxy -textvariable ltmp(httpproxy)
-	label $l.lhttpproxyport -text [::msgcat::mc "Proxy Port:"]
-	Spinbox $l.httpproxyport 0 65535 1 ltmp(httpproxyport)
+	set col 0
+	foreach type [jlib::capabilities proxy] {
+	    switch -- $type {
+		none {
+		   radiobutton $l.proxy.none -text [::msgcat::mc "None"] \
+			-variable ltmp(proxy) -value none \
+			-command [list [namespace current]::update_login_entries $l]
+		    grid $l.proxy.none -row 0 -column [incr col] -sticky w
+		}
+		socks4 {
+		   radiobutton $l.proxy.socks4 -text [::msgcat::mc "SOCKS4a"] \
+			-variable ltmp(proxy) -value socks4 \
+			-command [list [namespace current]::update_login_entries $l]
+		    grid $l.proxy.socks4 -row 0 -column [incr col] -sticky w
+		}
+		socks5 {
+		   radiobutton $l.proxy.socks5 -text [::msgcat::mc "SOCKS5"] \
+			-variable ltmp(proxy) -value socks5 \
+			-command [list [namespace current]::update_login_entries $l]
+		    grid $l.proxy.socks5 -row 0 -column [incr col] -sticky w
+		}
+		https {
+		   radiobutton $l.proxy.https -text [::msgcat::mc "HTTPS"] \
+			-variable ltmp(proxy) -value https \
+			-command [list [namespace current]::update_login_entries $l]
+		    grid $l.proxy.https -row 0 -column [incr col] -sticky w
+		}
+	    }
+	}
 
-	grid $l.lhttpproxy     -row 1 -column 0 -sticky e -in $proxy_page
-	grid $l.httpproxy      -row 1 -column 1 -sticky ew -in $proxy_page
-	grid $l.lhttpproxyport -row 1 -column 2 -sticky e -in $proxy_page
-	grid $l.httpproxyport  -row 1 -column 3 -sticky ew -in $proxy_page
+	label $l.lproxyhost -text [::msgcat::mc "Proxy server:"]
+	entry $l.proxyhost -textvariable ltmp(proxyhost)
+	label $l.lproxyport -text [::msgcat::mc "Proxy port:"]
+	Spinbox $l.proxyport 0 65535 1 ltmp(proxyport)
 
-	label $l.lhttplogin -text [::msgcat::mc "Proxy Login:"]
-	ecursor_entry [entry $l.httplogin -textvariable ltmp(httplogin)]
-	label $l.lhttppassword -text [::msgcat::mc "Proxy Password:"]
-	ecursor_entry [entry $l.httppassword -show * -textvariable ltmp(httppassword)]
+	grid $l.lproxyhost     -row 1 -column 0 -sticky e -in $proxy_page
+	grid $l.proxyhost      -row 1 -column 1 -sticky ew -in $proxy_page
+	grid $l.lproxyport -row 1 -column 2 -sticky e -in $proxy_page
+	grid $l.proxyport  -row 1 -column 3 -sticky ew -in $proxy_page
 
-	grid $l.lhttplogin    -row 2 -column 0 -sticky e -in $proxy_page
-	grid $l.httplogin     -row 2 -column 1 -sticky ew -in $proxy_page
-	grid $l.lhttppassword -row 2 -column 2 -sticky e -in $proxy_page
-	grid $l.httppassword  -row 2 -column 3 -sticky ew -in $proxy_page
+	label $l.lproxyusername -text [::msgcat::mc "Proxy username:"]
+	ecursor_entry [entry $l.proxyusername -textvariable ltmp(proxyusername)]
+	label $l.lproxypassword -text [::msgcat::mc "Proxy password:"]
+	ecursor_entry [entry $l.proxypassword -show * -textvariable ltmp(proxypassword)]
 
+	grid $l.lproxyusername    -row 2 -column 0 -sticky e -in $proxy_page
+	grid $l.proxyusername     -row 2 -column 1 -sticky ew -in $proxy_page
+	grid $l.lproxypassword -row 2 -column 2 -sticky e -in $proxy_page
+	grid $l.proxypassword  -row 2 -column 3 -sticky ew -in $proxy_page
+
 	grid columnconfigure $proxy_page 1 -weight 3
 	grid columnconfigure $proxy_page 2 -weight 1
 	grid columnconfigure $proxy_page 3 -weight 3

Added: trunk/tkabber/jabberlib-tclxml/autoconnect.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/autoconnect.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib-tclxml/autoconnect.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -0,0 +1,229 @@
+#  autoconnect.tcl ---
+#
+#      Interface to socks4/5 or https to make usage of 'socket' transparent.
+#      Can also be used as a wrapper for the 'socket' command without any
+#      proxy configured.
+#
+#  Copyright (c) 2007  Mats Bengtsson
+#  Modifications Copyright (c) Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+
+package provide autoconnect 0.1
+
+namespace eval autoconnect {
+    variable options
+    array set options {
+	-proxy          ""
+	-proxyhost      ""
+	-proxyport      ""
+	-proxyusername  ""
+	-proxypassword  ""
+	-proxyuseragent ""
+	-proxyno        ""
+	-proxyfilter    autoconnect::filter
+    }
+
+    variable packs
+    foreach name {socks4 socks5 https} {
+	if {![catch {package require $name}]} {
+	    set packs($name) 1
+	}
+    }
+}
+
+# autoconnect::configure --
+#
+#       Get or set configuration options for the proxy.
+#
+# Arguments:
+#       args:
+#           -proxy            ""|socks4|socks5|https
+#           -proxyhost        hostname
+#           -proxyport        port number
+#           -proxyusername    user ID
+#           -proxypassword    (socks5) password
+#           -proxyno          glob list of hosts to not use proxy
+#           -proxyfilter      tclProc {host}
+#
+# Results:
+#       one or many option values depending on arguments.
+
+proc autoconnect::configure {args} {
+    variable options
+    variable packs
+    if {[llength $args] == 0} {
+	return [array get options]
+    } elseif {[llength $args] == 1} {
+	return $options($args)
+    } else {
+	set idx [lsearch $args -proxy]
+	if {$idx >= 0} {
+	    set proxy [lindex $args [incr idx]]
+	    if {[string length $proxy] && ![info exists packs($proxy)]} {
+		return -code error "unsupported proxy \"$proxy\""
+	    }
+	}
+	array set options $args
+    }
+}
+
+proc autoconnect::init {} {
+    # @@@ Here we should get default settings from some system API.
+}
+
+# autoconnect::socket --
+#
+#       Subclassing the 'socket' command. Only client side.
+#       We use -command tclProc instead of -async + fileevent writable.
+#
+# Arguments:
+#       host:       the peer address, not SOCKS server
+#       port:       the peer's port number
+#       args:
+#           -command    tclProc {token status}
+#                       the 'status' is any of:
+#                       ok, error, timeout, network-failure,
+#                       rsp_*, err_* (see socks4/5)
+# Results:
+#	A socket if -command is not specified or an empty string.
+
+proc autoconnect::socket {host port args} {
+    variable options
+
+    set argsA(-command) ""
+    array set argsA $args
+    set proxy $options(-proxy)
+
+    set hostport [$options(-proxyfilter) $host]
+    if {[llength $hostport]} {
+	set ahost [lindex $hostport 0]
+	set aport [lindex $hostport 1]
+    } else {
+	set ahost $host
+	set aport $port
+    }
+
+    # Connect ahost + aport.
+    set sock [::socket -async $ahost $aport]
+    set token [namespace current]::$sock
+    variable $token
+    upvar 0 $token state
+
+    set state(host) $host
+    set state(port) $port
+    set state(sock) $sock
+    set state(cmd)  $argsA(-command)
+
+    fconfigure $sock -blocking 0
+    fileevent $sock writable [namespace code [list writable $token]]
+
+    if {[string length $state(cmd)]} {
+	return
+    } else {
+	vwait $token\(status)
+
+	set status $state(status)
+	set sock $state(sock)
+	catch {unset state}
+
+	if {[string equal $status OK]} {
+	    return $sock
+	} else {
+	    return -code error $sock
+	}
+    }
+}
+
+proc autoconnect::get_opts {} {
+    variable options
+
+    set opts [list]
+    if {[string length $options(-proxyusername)]} {
+	lappend opts -username $options(-proxyusername)
+    }
+    if {[string length $options(-proxypassword)]} {
+	lappend opts -password $options(-proxypassword)
+    }
+    if {[string length $options(-proxyuseragent)]} {
+	lappend opts -useragent $options(-proxyuseragent)
+    }
+    return $opts
+}
+
+proc autoconnect::writable {token} {
+    variable $token
+    upvar 0 $token state
+    variable options
+
+    set proxy $options(-proxy)
+    set sock $state(sock)
+    fileevent $sock writable {}
+
+    if {[catch {eof $sock} iseof] || $iseof} {
+	Finish $token network-failure
+    } else {
+	if {[string length $proxy]} {
+	    eval {${proxy}::connect $sock $state(host) $state(port) \
+		      -command [namespace code [list SocksCb $token]]
+		} [get_opts]
+	} else {
+	    Finish $token
+	}
+    }
+    return
+}
+
+proc autoconnect::SocksCb {token status sock} {
+    variable $token
+    upvar 0 $token state
+
+    if {[string equal $status OK]} {
+	set state(sock) $sock
+	Finish $token
+    } else {
+	Finish $token $sock
+    }
+    return
+}
+
+proc autoconnect::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+    variable options
+
+    if {[string length $state(cmd)]} {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(cmd) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(cmd) [list OK $state(sock)]
+	}
+	catch {unset state}
+    } else {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+proc autoconnect::filter {host} {
+    variable options
+    if {[llength $options(-proxy)]} {
+	foreach domain $options(-proxyno) {
+	    if {[string match $domain $host]} {
+		return [list]
+	    }
+	}
+	return [list $options(-proxyhost) $options(-proxyport)]
+    } else {
+	return [list]
+    }
+}


Property changes on: trunk/tkabber/jabberlib-tclxml/autoconnect.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Added: trunk/tkabber/jabberlib-tclxml/https.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/https.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib-tclxml/https.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -0,0 +1,656 @@
+# https.tcl --
+#
+#	Package for using the HTTP CONNECT (it is a common method for
+#	tunnelling HTTPS traffic, so the name is https) method for
+#	connecting TCP sockets. Only client side.
+#
+# Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+
+package require base64
+package require ntlm 1.0
+
+package provide https 1.0
+
+namespace eval https {
+    namespace export connect
+
+    variable debug 0
+}
+
+# https::connect --
+#
+#       Negotiates with a HTTPS proxy server.
+#
+# Arguments:
+#       sock:       an open socket token to the proxy server
+#       addr:       the peer address, not the proxy server
+#       port:       the peer port number
+#       args:
+#               -command    tclProc {status socket}
+#               -username   userid
+#               -password   password
+#               -useragent  useragent
+#               -timeout    millisecs (default 60000)
+#
+# Results:
+#       The connect socket or error if no -command, else empty string.
+#
+# Side effects:
+#	Socket is prepared for data transfer.
+#	If -command specified, the callback tclProc is called with
+#	status OK and socket or ERROR and error message.
+
+proc https::connect {sock addr port args} {
+    variable auth
+
+    set token [namespace current]::$sock
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::connect token=$token, sock=$sock, addr=$addr,\
+	     port=$port, args=$args"
+
+    array set state {
+	-command    ""
+	-timeout    60000
+	-username   ""
+	-password   ""
+	-useragent  ""
+	async       0
+	status	    ""
+    }
+    array set state [list   \
+	addr        $addr \
+	port        $port \
+	sock        $sock \
+	peer	    [fconfigure $sock -peername]]
+    array set state $args
+
+    if {[string length $state(-command)]} {
+	set state(async) 1
+    }
+
+    PutsConnectQuery $token
+
+    fileevent $sock readable  \
+	[list [namespace current]::Readable $token]
+
+    # Setup timeout timer.
+    set state(timeoutid) \
+	[after $state(-timeout) [namespace current]::Timeout $token]
+
+    if {$state(async)} {
+	return
+    } else {
+	# We should not return from this proc until finished!
+	vwait $token\(status)
+
+	set status $state(status)
+	set sock $state(sock)
+
+	Free $token
+
+	if {[string equal $status OK]} {
+	    return $sock
+	} else {
+	    return -code error $sock
+	}
+    }
+}
+
+# https::Readable --
+#
+#	Receive the first reply from a proxy and either finish the
+#	negotiations or prepare to autorization process at the proxy.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	The negotiation is finished or the next turn is started.
+
+proc https::Readable {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::Readable token=$token"
+
+    fileevent $state(sock) readable {}
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $state(sock)]]} {}
+	Finish $token
+    } elseif {$code != 407} {
+	# Failure
+	Finish $token $state(result)
+    } else {
+	# Authorization required
+	set content_length -1
+	set method basic
+	while {[string length [set header [gets $state(sock)]]]} {
+	    switch -- [HttpHeaderName $header] {
+		proxy-authenticate {
+		    if {[string equal -length 4 [HttpHeaderBody $header] "NTLM"]} {
+			set method ntlm
+		    }
+		}
+		content-length {
+		    set content_length [HttpHeaderBody $header]
+		}
+	    }
+	}
+
+	ReadProxyJunk $token $content_length
+	close $state(sock)
+
+	set state(sock) \
+	    [socket -async [lindex $state(peer) 0] [lindex $state(peer) 2]]
+
+	fileevent $state(sock) writable \
+	    [list [namespace current]::Authorize $token $method]
+    }
+
+    return
+}
+
+# https::Authorize --
+#
+#	Start the authorization procedure.
+#
+# Arguments:
+#	token	    A connection token.
+#	method	    (basic or ntlm) authorization method.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Authorization is started.
+
+proc https::Authorize {token method} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::Authorize token=$token, method=$method"
+
+    switch -- $method {
+	ntlm {
+	    AuthorizeNtlmStep1 $token
+	}
+	default {
+	    AuthorizeBasicStep1 $token
+	}
+    }
+
+    return
+}
+
+# https::AuthorizeBasicStep1 --
+#
+#	The first step of basic authorization procedure: send authorization
+#	credentials to a socket.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Authorization info is sent to a socket.
+
+proc https::AuthorizeBasicStep1 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeBasicStep1 token=$token"
+
+    set auth \
+	[string map {\n {}} \
+	     [base64::encode \
+		  [encoding convertto "$state(-username):$state(-$password)"]]]
+
+    PutsConnectQuery $token "Basic $auth"
+
+    fileevent $state(sock) readable \
+	[list [namespace current]::AuthorizeBasicStep2 $token]
+
+    return
+}
+
+# https::AuthorizeBasicStep2 --
+#
+#	The second step of basic authorization procedure: receive and
+#	analyze server reply.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Server reply is received from a socket.
+
+proc https::AuthorizeBasicStep2 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeBasicStep2 token=$token"
+
+    fileevent $state(sock) readable {}
+
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $sock]]} { }
+	Finish $token
+    } else {
+	# Failure
+	Finish $token $state(result)
+    }
+    return
+}
+
+# https::AuthorizeNtlmStep1 --
+#
+#	The first step of NTLM authorization procedure: send NTLM
+#	message 1 to a socket.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Authorization info is sent to a socket.
+
+proc https::AuthorizeNtlmStep1 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeNtlmStep1 token=$token"
+
+    set domain ""
+    set host [info hostname]
+
+    # if username is domain/username or domain\username
+    # then set domain and username
+    regexp {(\w+)[\\/](.*)} $username -> domain username
+
+    set ntlmtok [NTLM::new -domain $domain \
+			   -host $host \
+			   -username $state(-username) \
+			   -password $state(-password)]
+    set message1 [$ntlmtok type1Message]
+
+    PutsConnectQuery $token "NTLM $message1"
+
+    fileevent $state(sock) readable \
+	[list [namespace current]::AuthorizeNtlmStep2 $token]
+
+    return
+}
+
+# https::AuthorizeNtlmStep2 --
+#
+#	The first step of basic authorization procedure: send authorization
+#	credentials to a socket.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Authorization info is sent to a socket.
+
+proc https::AuthorizeNtlmStep2 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeNtlmStep2 token=$token"
+
+    fileevent $state(sock) readable {}
+
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $state(sock)]]} { }
+	Finish $token
+    } elseif {$code != 407} {
+	# Failure
+	Finish $token $state(result)
+    }
+
+    set content_length -1
+    set message2 ""
+    while {![string equal [set header [gets $state(sock)]] ""]} {
+	switch -- [HttpHeaderName $header] {
+	    proxy-authenticate {
+		set body [HttpHeaderBody $header]
+		if {[string equal -length 5 $body "NTLM "]} {
+		    set message2 [string trim [string range $body 5 end]]
+		}
+	    }
+	    content-length {
+		set content_length [HttpHeaderBody $header]
+	    }
+	}
+    }
+
+    ReadProxyJunk $token $content_length
+
+    $ntlmtok parseType2Message -message $message2
+    set message3 [$ntlmtok type3Message]
+    $ntlmtok free
+
+    PutsConnectQuery $token "NTLM $message3"
+
+    fileevent $state(sock) readable \
+	[list [namespace current]::AuthorizeNtlmStep3 $token]
+
+    return
+}
+
+# https::AuthorizeNtlmStep3 --
+#
+#	The third step of NTLM authorization procedure: receive and
+#	analyze server reply.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Server reply is received from a socket.
+
+proc https::AuthorizeNtlmStep3 {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::AuthorizeNtlmStep3 token=$token"
+
+    fileevent $state(sock) readable {}
+
+    set code [ReadProxyAnswer $token]
+
+    if {$code >= 200 && $code < 300} {
+	# Success
+	while {[string length [gets $state(sock)]]} { }
+	Finish $token
+    } else {
+	# Failure
+	Finish $token $state(result)
+    }
+    return
+}
+
+# https::PutsConnectQuery --
+#
+#	Sends CONNECT query to a proxy server.
+#
+# Arguments:
+#	token	    A connection token.
+#	auth	    (optional) A proxy authorization string.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Some info is sent to a proxy.
+
+proc https::PutsConnectQuery {token {auth ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::PutsConnectQuery token=$token auth=$auth"
+
+    fconfigure $state(sock) -buffering line -translation auto
+
+    puts $state(sock) "CONNECT $state(addr):$state(port) HTTP/1.1"
+    puts $state(sock) "Proxy-Connection: keep-alive"
+    if {[string length $state(-useragent)]} {
+	puts $state(sock) "User-Agent: $state(-useragent)"
+    }
+    if {[string length $auth]} {
+	puts $state(sock) "Proxy-Authorization: $auth"
+    }
+    puts $state(sock) ""
+    return
+}
+
+# https::ReadProxyAnswer --
+#
+#	Reads the first line of a proxy answer with a result code.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	The HTTP result code.
+#
+# Side effects:
+#	Status line is read form a socket.
+#	Variable state(result) is set to a just read line.
+
+proc https::ReadProxyAnswer {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::ReadProxyAnswer token=$token"
+
+    fconfigure $state(sock) -buffering line -translation auto
+
+    set state(result) [gets $state(sock)]
+    set code [lindex [split $state(result) { }] 1]
+    if {[string is integer -strict $code]} {
+	return $code
+    } else {
+	# Invalid code
+	return 0
+    }
+}
+
+# https::ReadProxyJunk --
+#
+#	Reads the body part of a proxy answer.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	Empty string.
+#
+# Side effects:
+#	Some info is read from a socket and discarded.
+
+proc https::ReadProxyJunk {token length} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::ReadProxyJunk token=$token, length=$length"
+
+    fconfigure $state(sock) -buffering none -translation binary
+    if {$length != -1} {
+	read $state(sock) $length
+    } else {
+	read $state(sock)
+    }
+    return
+}
+
+# https::HttpHeaderName --
+#
+#	Returns HTTP header name (converted to lowercase).
+#
+# Arguments:
+#	header	    A HTTP header.
+#
+# Result:
+#	A header name.
+#
+# Side effects
+#	None.
+
+proc https::HttpHeaderName {header} {
+    set hlist [split $header ":"]
+    return [string tolower [lindex $hlist 0]]
+}
+
+# https::HttpHeaderBody --
+#
+#	Returns HTTP header body.
+#
+# Arguments:
+#	header	    A HTTP header.
+#
+# Result:
+#	A header body.
+#
+# Side effects
+#	None.
+
+proc https::HttpHeaderBody {header} {
+    set hlist [split $header ":"]
+    set body [join [lrange $hlist 1 end] ":"]
+    return [string trim $body]
+}
+
+# https::Timeout --
+#
+#	This proc is called in case of timeout.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A proxy negotiation is finished with error.
+
+proc https::Timeout {token} {
+    Finish $token timeout
+    return
+}
+
+# https::Free --
+#
+#	Frees a connection token.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A connection token and its state informationa are destroyed.
+
+proc https::Free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {after cancel $state(timeoutid)}
+    catch {unset state}
+    return
+}
+
+# https::Finish --
+#
+#	Finishes a negotiation process.
+#
+# Arguments:
+#	token	    A connection token.
+#	errormsg    (optional) error message.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	If connection is asynchronous then a callback is executed.
+#	Otherwise state(status) is set to allow https::connect to return
+#	with either success or error.
+
+proc https::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "https::Finish token=$token, errormsg=$errormsg"
+
+    catch {after cancel $state(timeoutid)}
+
+    if {$state(async)} {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(-command) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(-command) [list OK $state(sock)]
+	}
+	Free $token
+    } else {
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+# https::Debug --
+#
+#	Prints debug information.
+#
+# Arguments:
+#	num	A debug level.
+#	str	A debug message.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A debug message is printed to the console if the value of
+#	https::debug variable is not less than num.
+
+proc https::Debug {num str} {
+    variable debug
+
+    if {$num <= $debug} {
+	puts $str
+    }
+
+    return
+}
+
+# Test
+if {0} {
+    set s [socket 192.168.0.1 3128]
+    set t [https::connect $s google.com 443]
+    puts $t
+    close $t
+
+    set s [socket 192.168.0.1 3128]
+    set t [https::connect $s google.com 80]
+    puts $t
+    close $t
+}
+


Property changes on: trunk/tkabber/jabberlib-tclxml/https.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Modified: trunk/tkabber/jabberlib-tclxml/jabberlib.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/jabberlib-tclxml/jabberlib.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -81,6 +81,8 @@
 package require jlibauth 1.0
 package require jlibdns 1.0
 
+package require autoconnect 0.1
+
 ######################################################################
 
 namespace eval jlib {
@@ -235,6 +237,9 @@
 
     ::LOG "(jlib::connect) Server:'$server' ConnectionID:'$connid'"
 
+    # TODO: do not change autoconnect options on every login.
+    eval autoconnect::configure $args
+
     foreach hp $hosts {
 	if {[catch {
 		eval [list transport::${transport}::connect \

Modified: trunk/tkabber/jabberlib-tclxml/ntlm.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/ntlm.tcl	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/jabberlib-tclxml/ntlm.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -1,18 +1,26 @@
-# Copyright (c) 2004 Sergei Golovan <sgolovan at nes.ru>
+# ntlm.tcl --
 #
-# Tcl NTLM Authentication messages module
-# This module is based on Mozilla NTLM authenticattion module and
-# documentation from http://davenport.sourceforge.net/ntlm.html
+#	This file implements NTLM Authentication messages in Tcl.
+#	This module is based on Mozilla NTLM authenticattion module and
+#	documentation from http://davenport.sourceforge.net/ntlm.html
+#
+# Copyright (c) 2004-2007 Sergei Golovan <sgolovan at nes.ru>
+#
+# This file is distributed under BSD license.
+#
+# $Id$
 
 package require des
 package require md4
-package require md5 2.0
+package require md5
 package require base64
 
-package provide ntlm 0.1
+package provide ntlm 1.0
 
 namespace eval NTLM {
-    # flags
+    namespace export new free type1Message parseType2Message type3Messasge
+
+    # NTLM flags.
     array set NTLM {
 	NegotiateUnicode             0x00000001
 	NegotiateOEM                 0x00000002
@@ -47,7 +55,7 @@
 	NegotiateKeyExchange         0x40000000
 	Negotiate56                  0x80000000
     }
-    # send these flags with our type 1 message
+    # Send these flags with our Type1 message.
     set NTLM(TYPE1_FLAGS_INT) [expr {($NTLM(NegotiateUnicode) | \
 				      $NTLM(NegotiateOEM)     | \
 				      $NTLM(RequestTarget)    | \
@@ -55,7 +63,7 @@
 				      $NTLM(NegotiateNTLM2Key))}]
     set NTLM(TYPE1_FLAGS) [binary format i $NTLM(TYPE1_FLAGS_INT)]
 
-    # markers and signatures
+    # Markers and signatures.
     array set NTLM [list \
 	SIGNATURE    [binary format a8 "NTLMSSP"] \
 	TYPE1_MARKER [binary format i 1]          \
@@ -63,23 +71,27 @@
 	TYPE3_MARKER [binary format i 3]          \
 	LM_MAGIC     [binary format a* "KGS!@#$%"]]
     
-    # token counter
+    # Token counter.
     variable uid 0
 }
 
-###########################################################################
+# NTLM::new --
 #
-#   NTLM::new allocates new NTLM token
+#	Allocates new NTLM token.
 #
-#   args:   ?-domain Domain?
-#	    ?-host Host?
-#	    ?-username Username?
-#	    ?-password Password?
+# Arguments:
+#	    -domain   Domain	(optional)
+#	    -host     Host	(optional)
+#	    -username Username	(optional)
+#	    -password Password	(optional)
+#	    All credentials are empty strings by default.
 #
-#   all credentials are empty strings by default
+# Result:
+#	A NTLM token.
 #
-#   results: token
-#
+# Side effects:
+#	A new state variable in NTLM namespace is created. Also,
+#	a new procedure with token name is created.
 
 proc NTLM::new {args} {
     variable uid
@@ -113,12 +125,18 @@
     return $token
 }
 
-###########################################################################
+# NTLM::free --
 #
-#   NTLM::free frees previously allocated NTLM token
+#	Frees previously allocated NTLM token.
 #
-#   args: token
+# Arguments:
+#	token	    A previously allocated NTLM token.
 #
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A state variable is destroyed.
 
 proc NTLM::free {token} {
     variable $token
@@ -126,19 +144,23 @@
 
     catch {unset state}
     catch {rename $token ""}
+    return
 }
 
-###########################################################################
+# NTLM::type1Message --
 #
-#   NTLM::type1_message generates NTLM Type1 message (start of
-#	the authentication process)
+#	Generates NTLM Type1 message (start of the authentication process).
 #
-#   args: token
+# Arguments:
+#	token	    A NTLM token.
 #
-#   results: base64 encoded NTLM Type1 message
+# Result:
+#	A BASE64 encoded NTLM Type1 message.
 #
+# Side effects:
+#	None.
 
-proc NTLM::type1_message {token} {
+proc NTLM::type1Message {token} {
     variable NTLM
     variable $token
     upvar 0 $token state
@@ -153,16 +175,21 @@
     return [string map {\n {}} [base64::encode $msg1]]
 }
 
-###########################################################################
+# NTLM::parseType2Message --
 #
-#   NTLM::parse_type2_message parses NTLM Type2 message (server response)
-#	and stores given challenge in state variable
+#	Parses NTLM Type2 message (server response).
 #
-#   args:   token
-#	    -message Message
+# Arguments:
+#	token		    A NTLM token.
+#	-message Message    (required) A server Type2 message.
 #
+# Result:
+#	Empty string in case of success or error if something goes wrong.
+#
+# Side effects:
+#	A target, challenge and negotiated flags are stored in state variable.
 
-proc NTLM::parse_type2_message {token args} {
+proc NTLM::parseType2Message {token args} {
     variable NTLM
     variable $token
     upvar 0 $token state
@@ -205,20 +232,23 @@
     # storing and returning challenge
     set state(challenge) [string range $msg2 24 31]
 
-    return ""
+    return
 }
 
-###########################################################################
+# NTLM::type3Message --
 #
-#   NTLM::type3_message generates NTLM Type3 message (end of
-#	the authentication process)
+#	Generates NTLM Type3 message (the end of the authentication process).
 #
-#   args: token
+# Arguments:
+#	token	    A NTLM token after parsing Type2 message.
 #
-#   results: base64 encoded NTLM Type3 message
+# Result:
+#	A BASE64 encoded NTLM Type3 message.
 #
+# Side effects:
+#	None.
 
-proc NTLM::type3_message {token} {
+proc NTLM::type3Message {token} {
     variable NTLM
     variable $token
     upvar 0 $token state
@@ -227,9 +257,9 @@
     set target_type_domain [expr {$state(flags) & $NTLM(TargetTypeDomain)}]
 
     if {$unicode} {
-	set domain [to_unicode_le [string toupper $state(-domain)]]
-	set host [to_unicode_le [string toupper $state(-host)]]
-	set username [to_unicode_le $state(-username)]
+	set domain [ToUnicodeLe [string toupper $state(-domain)]]
+	set host [ToUnicodeLe [string toupper $state(-host)]]
+	set username [ToUnicodeLe $state(-username)]
     } else {
 	set domain [encoding convertto [string toupper $state(-domain)]]
 	set host [encoding convertto [string toupper $state(-host)]]
@@ -249,26 +279,26 @@
 	set random [binary format ssss $rnd1 $rnd2 $rnd3 $rnd4]
 
 	set lm_response [binary format a24 $random]
-	set session_hash [md5::md5 -- [binary format a8a8 $challenge $random]]
+	set session_hash [md5 [binary format a8a8 $challenge $random]]
 
-	set ntlm_hash [NTLM_hash $state(-password)]
-	set ntlm_response [LM_response $ntlm_hash $session_hash]
+	set ntlm_hash [NtlmHash $state(-password)]
+	set ntlm_response [LmResponse $ntlm_hash $session_hash]
     } else {
-	set lm_hash [LM_hash $state(-password)]
-	set lm_response [LM_response $lm_hash $challenge]
+	set lm_hash [LmHash $state(-password)]
+	set lm_response [LmResponse $lm_hash $challenge]
 	
-	set ntlm_hash [NTLM_hash $state(-password)]
-	set ntlm_response [LM_response $ntlm_hash $challenge]
+	set ntlm_hash [NtlmHash $state(-password)]
+	set ntlm_response [LmResponse $ntlm_hash $challenge]
     }
 
-    # offset of the end of header
+    # Offset of the end of header.
     set offset 64
 
-    set offset [create_data $domain        $offset data(domain)]
-    set offset [create_data $username      $offset data(username)]
-    set offset [create_data $host          $offset data(host)]
-    set offset [create_data $lm_response   $offset data(lm)]
-    set offset [create_data $ntlm_response $offset data(ntlm)]
+    set offset [CreateData $domain        $offset data(domain)]
+    set offset [CreateData $username      $offset data(username)]
+    set offset [CreateData $host          $offset data(host)]
+    set offset [CreateData $lm_response   $offset data(lm)]
+    set offset [CreateData $ntlm_response $offset data(ntlm)]
 
     set flags [expr {$state(flags) & $NTLM(TYPE1_FLAGS_INT)}]
 
@@ -281,17 +311,66 @@
     return [string map {\n {}} [base64::encode $msg3]]
 }
 
-# create_data returns next offset (in error code) and security buffer data
-proc NTLM::create_data {str offset datavar} {
-    upvar $datavar data
+# NTLM::md5 --
+#
+#	Returns binary MD5 hash of specified string. This procedure is needed
+#	if md5 package has version less than 2.0.
+#
+# Arguments:
+#	str
+#
+# Result:
+#	The binary MD5 hash.
+#
+# Side effects:
+#	None.
 
+proc NTLM::md5 {str} {
+    if {[catch {::md5::md5 -hex $str} hash]} {
+	# Old md5 package.
+	set hash [::md5::md5 $str]
+    }
+    return [binary format H32 $hash]
+}
+
+# NTLM::CreateData --
+#
+#	Returns next offset (in error code) and security buffer data
+#
+# Arguments:
+#	str
+#	offset
+#	dataVar
+#
+# Result:
+#	The next offset.
+#
+# Side effects:
+#	Variable dataVar is set to a binary value for packing into a NTLM
+#	message.
+
+proc NTLM::CreateData {str offset dataVar} {
+    upvar $dataVar data
+
     set len [string length $str]
     set data [binary format ssi $len $len $offset]
     return [expr {$offset + $len}]
 }
 
-# LM_Hash computes the LM hash of the given password.
-proc NTLM::LM_hash {password} {
+# NTLM::LmHash --
+#
+#	Computes the LM hash of the given password.
+#
+# Arguments:
+#	password	A password to hash.
+#
+# Result:
+#	A LM hash of the given password.
+#
+# Side effects:
+#	None.
+
+proc NTLM::LmHash {password} {
     variable NTLM
 
     set password [encoding convertto [string toupper $password]]
@@ -300,8 +379,8 @@
     set pwd [binary format a14 $password]
 
     # setup two DES keys
-    set key1 [make_key [string range $pwd 0 6]]
-    set key2 [make_key [string range $pwd 7 13]]
+    set key1 [MakeKey [string range $pwd 0 6]]
+    set key2 [MakeKey [string range $pwd 7 13]]
 
     # do hash
     set res1 [DES::des -mode encode -key $key1 $NTLM(LM_MAGIC)]
@@ -310,26 +389,51 @@
     return [binary format a8a8 $res1 $res2]
 }
 
-# NTLM_Hash computes the NTLM hash of the given password.
-proc NTLM::NTLM_hash {password} {
+# NTLM::NtlmHash --
+#
+#	Computes the NTLM hash of the given password.
+#
+# Arguments:
+#	password	A password to hash.
+#
+# Result:
+#	A NTLM hash of the given password.
+#
+# Side effects:
+#	None.
+
+proc NTLM::NtlmHash {password} {
     # we have to have UNICODE password
-    set pw [to_unicode_le $password]
+    set pw [ToUnicodeLe $password]
 
     # do MD4 hash
     return [md4::md4 -- $pw]
 }
 
-# LM_Response generates the LM response given a 16-byte password hash and the
-# challenge from the Type-2 message.
-proc NTLM::LM_response {hash challenge} {
+# NTLM::LmResponse --
+#
+#	Generates the LM response given a 16-byte password hash and the
+#	challenge from the Type-2 message.
+#
+# Arguments:
+#	hash	    A password hash
+#	challenge   A challenge.
+#
+# Result:
+#	A LM hash (3 concatenated DES-encrypted strings).
+#
+# Side effects:
+#	None.
+
+proc NTLM::LmResponse {hash challenge} {
     # zero pad hash to 21 bytes
     set hash [binary format a21 $hash]
     # truncate challenge to 8 bytes
     set challenge [binary format a8 $challenge]
 
-    set key1 [make_key [string range $hash 0 6]]
-    set key2 [make_key [string range $hash 7 13]]
-    set key3 [make_key [string range $hash 14 20]]
+    set key1 [MakeKey [string range $hash 0 6]]
+    set key2 [MakeKey [string range $hash 7 13]]
+    set key3 [MakeKey [string range $hash 14 20]]
 
     set res1 [DES::des -mode encode -key $key1 $challenge]
     set res2 [DES::des -mode encode -key $key2 $challenge]
@@ -338,30 +442,55 @@
     return [binary format a8a8a8 $res1 $res2 $res3]
 }
 
-# make_key builds 64-bit des key from 56-bit raw key
-proc NTLM::make_key {key} {
+# NTLM::MakeKey --
+#
+#	Builds 64-bit DES key from 56-bit raw key.
+#
+# Arguments:
+#	key	A 56-bit key.
+#
+# Result:
+#	A 64-bit DES key.
+#
+# Side effects:
+#	None.
+
+proc NTLM::MakeKey {key} {
     binary scan $key ccccccc k(0) k(1) k(2) k(3) k(4) k(5) k(6)
     # make numbers unsigned
     foreach i [array names k] {
 	set k($i) [expr {($k($i) + 0x100) % 0x100}]
     }
 
-    set n(0) [set_key_parity $k(0)]
-    set n(1) [set_key_parity [expr {(($k(0) << 7) & 0xFF) | ($k(1) >> 1)}]]
-    set n(2) [set_key_parity [expr {(($k(1) << 6) & 0xFF) | ($k(2) >> 2)}]]
-    set n(3) [set_key_parity [expr {(($k(2) << 5) & 0xFF) | ($k(3) >> 3)}]]
-    set n(4) [set_key_parity [expr {(($k(3) << 4) & 0xFF) | ($k(4) >> 4)}]]
-    set n(5) [set_key_parity [expr {(($k(4) << 3) & 0xFF) | ($k(5) >> 5)}]]
-    set n(6) [set_key_parity [expr {(($k(5) << 2) & 0xFF) | ($k(6) >> 6)}]]
-    set n(7) [set_key_parity [expr  {($k(6) << 1) & 0xFF}]]
+    set n(0) [SetKeyParity $k(0)]
+    set n(1) [SetKeyParity [expr {(($k(0) << 7) & 0xFF) | ($k(1) >> 1)}]]
+    set n(2) [SetKeyParity [expr {(($k(1) << 6) & 0xFF) | ($k(2) >> 2)}]]
+    set n(3) [SetKeyParity [expr {(($k(2) << 5) & 0xFF) | ($k(3) >> 3)}]]
+    set n(4) [SetKeyParity [expr {(($k(3) << 4) & 0xFF) | ($k(4) >> 4)}]]
+    set n(5) [SetKeyParity [expr {(($k(4) << 3) & 0xFF) | ($k(5) >> 5)}]]
+    set n(6) [SetKeyParity [expr {(($k(5) << 2) & 0xFF) | ($k(6) >> 6)}]]
+    set n(7) [SetKeyParity [expr  {($k(6) << 1) & 0xFF}]]
 
     return [binary format cccccccc \
 		$n(0) $n(1) $n(2) $n(3) $n(4) $n(5) $n(6) $n(7)]
 }
 
-# set_key_parity sets odd parity bit (in least significant bit position)
-# DES::des seems not to require setting parity, but...
-proc NTLM::set_key_parity {x} {
+# NTLM::SetKeyParity --
+#
+#	Sets odd parity bit (in least significant bit position)
+#	DES::des seems not to require setting parity, but...
+#
+# Arguments:
+#	x	A byte integer.
+#
+# Result:
+#	An integer with parity bit set, so the total number of bits set is
+#	odd.
+#
+# Side effects:
+#	None.
+
+proc NTLM::SetKeyParity {x} {
     set xor [expr {(($x >> 7) ^ ($x >> 6) ^ ($x >> 5) ^
 		    ($x >> 4) ^ ($x >> 3) ^ ($x >> 2) ^
 		    ($x >> 1)) & 0x01}]
@@ -372,9 +501,21 @@
     }
 }
 
-# Convert a string to unicode in little endian byte order.
-# (taken from tcllib/sasl)
-proc NTLM::to_unicode_le {str} {
+# NTLM::ToUnicodeLe --
+#
+#	Converts a string to unicode in little endian byte order
+#	(taken from tcllib/sasl).
+#
+# Arguments:
+#	str	A string to convert.
+#
+# Result:
+#	A converted to little endian byte order string.
+#
+# Side effects:
+#	None.
+
+proc NTLM::ToUnicodeLe {str} {
     set result [encoding convertto unicode $str]
     if {[string equal $::tcl_platform(byteOrder) "bigEndian"]} {
 	set r {} ; set n 0

Modified: trunk/tkabber/jabberlib-tclxml/pkgIndex.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/pkgIndex.tcl	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/jabberlib-tclxml/pkgIndex.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -8,6 +8,10 @@
 package ifneeded stanzaerror 1.0 [list source [file join $dir stanzaerror.tcl]]
 package ifneeded jlibdns 1.0 [list source [file join $dir jlibdns.tcl]]
 package ifneeded idna 1.0 [list source [file join $dir idna.tcl]]
-package ifneeded ntlm 0.1 [list source [file join $dir ntlm.tcl]]
+package ifneeded ntlm 1.0 [list source [file join $dir ntlm.tcl]]
+package ifneeded autoconnect 0.1 [list source [file join $dir autoconnect.tcl]]
+package ifneeded socks4 1.0 [list source [file join $dir socks4.tcl]]
+package ifneeded socks5 1.0 [list source [file join $dir socks5.tcl]]
+package ifneeded https 1.0 [list source [file join $dir https.tcl]]
 
 # don't forget to define ::LOG

Added: trunk/tkabber/jabberlib-tclxml/socks4.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/socks4.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib-tclxml/socks4.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -0,0 +1,322 @@
+# socks4.tcl ---
+#
+#	Package for using the SOCKS4a method for connecting TCP sockets.
+#	Only client side.
+#
+# Copyright (c) 2007  Mats Bengtsson
+# Modifications Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+
+package provide socks4 1.0
+
+namespace eval socks4 {
+    namespace export connect
+
+    variable const
+    array set const {
+	ver                 \x04
+	cmd_connect         \x01
+	cmd_bind            \x02
+	rsp_granted         \x5a
+	rsp_failure         \x5b
+	rsp_errconnect      \x5c
+	rsp_erruserid       \x5d
+    }
+
+    # Practical when mapping errors to error codes.
+    variable iconst
+    array set iconst {
+	4   ver
+	1   cmd_connect
+	2   cmd_bind
+	90  rsp_granted
+	91  rsp_failure
+	92  rsp_errconnect
+	93  rsp_erruserid
+    }
+
+    variable debug 0
+}
+
+# socks4::connect --
+#
+#       Negotiates with a SOCKS server.
+#
+# Arguments:
+#       sock:       an open socket token to the SOCKS server
+#       addr:       the peer address, not SOCKS server
+#       port:       the peer's port number
+#       args:
+#               -command    tclProc {token status}
+#               -username   userid
+#               -timeout    millisecs (default 60000)
+#
+# Results:
+#       The connect socket or error if no -command, else empty string.
+#
+# Side effects:
+#	Socket is prepared for data transfer.
+#	If -command specified, the callback tclProc is called with
+#	status OK and socket or ERROR and error message.
+
+proc socks4::connect {sock addr port args} {
+    variable const
+
+    set token [namespace current]::$sock
+    variable $token
+    upvar 0 $token state
+
+    array set state {
+	-command    ""
+	-timeout    60000
+	-username   ""
+	async       0
+	bnd_addr    ""
+	bnd_port    ""
+	status      ""
+    }
+    array set state [list \
+	addr        $addr \
+	port        $port \
+	sock        $sock]
+    array set state $args
+
+    if {[string length $state(-command)]} {
+	set state(async) 1
+    }
+
+    # Network byte-ordered port (2 binary-bytes, short)
+    set bport [binary format S $port]
+
+    # This corresponds to IP address 0.0.0.x, with x nonzero.
+    set bip \x00\x00\x00\x01
+
+    set bdata "$const(ver)$const(cmd_connect)$bport$bip"
+    append bdata "$state(-username)\x00$addr\x00"
+
+    fconfigure $sock -translation binary -blocking 0
+    fileevent $sock writable {}
+
+    if {[catch {
+	puts -nonewline $sock $bdata
+	flush $sock
+    } err]} {
+	if {$state(async)} {
+	    after idle [list $state(-command) ERROR network-failure]
+	    Free $token
+	    return
+	} else {
+	    Free $token
+	    return -code error $err
+	}
+    }
+
+    # Setup timeout timer.
+    set state(timeoutid)  \
+	[after $state(-timeout) [namespace current]::Timeout $token]
+
+    fileevent $sock readable  \
+	[list [namespace current]::Response $token]
+
+    if {$state(async)} {
+	return
+    } else {
+	# We should not return from this proc until finished!
+	vwait $token\(status)
+
+	set status $state(status)
+	set sock $state(sock)
+
+	Free $token
+
+	if {[string equal $status OK]} {
+	    return $sock
+	} else {
+	    return -code error $sock
+	}
+    }
+}
+
+# socks4::Response --
+#
+#	Receive the reply from a proxy and finish the negotiations.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	The negotiation is finished with either success or error.
+
+proc socks4::Response {token} {
+    variable $token
+    upvar 0 $token state
+    variable const
+    variable iconst
+
+    Debug 2 "socks4::response"
+
+    set sock $state(sock)
+    fileevent $sock readable {}
+
+    # Read and parse status.
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    binary scan $data cc null status
+    if {![string equal $null 0]} {
+	Finish $token err_version
+	return
+    }
+    if {![string equal $status $const(rsp_granted)]} {
+	if {[info exists iconst($status)]} {
+	    Finish $token $iconst($status)
+	} else {
+	    Finish $token error
+	}
+	return
+    }
+
+    # Read and parse port (2 bytes) and ip (4 bytes).
+    if {[catch {read $sock 6} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    binary scan $data ccccS i0 i1 i2 i3 port
+    set addr ""
+    foreach n [list $i0 $i1 $i2 $i3] {
+	# Translate to unsigned!
+	append addr [expr ( $n + 0x100 ) % 0x100]
+	if {$n <= 2} {
+	    append addr .
+	}
+    }
+    # Translate to unsigned!
+    set port [expr ( $port + 0x10000 ) % 0x10000]
+    set state(bnd_port) $port
+    set state(bnd_addr) $addr
+
+    Finish $token
+    return
+}
+
+# socks4::Timeout --
+#
+#	This proc is called in case of timeout.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A proxy negotiation is finished with error.
+
+proc socks4::Timeout {token} {
+    Finish $token timeout
+    return
+}
+
+# socks4::Free --
+#
+#	Frees a connection token.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A connection token and its state informationa are destroyed.
+
+proc socks4::Free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {after cancel $state(timeoutid)}
+    catch {unset state}
+    return
+}
+
+# socks4::Finish --
+#
+#	Finishes a negotiation process.
+#
+# Arguments:
+#	token	    A connection token.
+#	errormsg    (optional) error message.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	If connection is asynchronous then a callback is executed.
+#	Otherwise state(status) is set to allow https::connect to return
+#	with either success or error.
+
+proc socks4::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks4::Finish token=$token, errormsg=$errormsg"
+
+    catch {after cancel $state(timeoutid)}
+
+    if {$state(async)} {
+	# In case of asynchronous connection we do the cleanup.
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(-command) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(-command) [list OK $state(sock)]
+	}
+	Free $token
+    } else {
+	# Otherwise we trigger state(status).
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+# https::Debug --
+#
+#	Prints debug information.
+#
+# Arguments:
+#	num	A debug level.
+#	str	A debug message.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A debug message is printed to the console if the value of
+#	https::debug variable is not less than num.
+
+proc socks4::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+# Test
+if {0} {
+    set s [socket 192.168.0.1 1080]
+    set t [socks4::connect $s jabber.ru 5222 -username sergei]
+}
+


Property changes on: trunk/tkabber/jabberlib-tclxml/socks4.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Added: trunk/tkabber/jabberlib-tclxml/socks5.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/socks5.tcl	                        (rev 0)
+++ trunk/tkabber/jabberlib-tclxml/socks5.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -0,0 +1,1063 @@
+#  socks5.tcl ---
+#
+#      Package for using the SOCKS5 method for connecting TCP sockets.
+#      Some code plus idee from Kerem 'Waster_' HADIMLI.
+#      Made from RFC 1928.
+#
+#  Copyright (c) 2000  Kerem 'Waster_' HADIMLI (minor parts)
+#  Copyright (c) 2003-2007  Mats Bengtsson
+#  Modifications Copyright (c) 2007 Sergei Golovan <sgolovan at nes.ru>
+#
+#  This source file is distributed under the BSD license.
+#
+# $Id$
+#
+# TODO:  GSSAPI authentication which is a MUST is missing.
+#        Only CMD CONNECT implemented.
+#        Do not report English text in callback but rather error keys like
+#        rsp_notallowed etc. Client done, server to go.
+
+package provide socks5 1.0
+
+namespace eval socks5 {
+    namespace export connect
+
+    # Constants:
+    # ver:                Socks version
+    # nomatchingmethod:   No matching methods
+    # cmd_connect:        Connect command
+    # rsv:                Reserved
+    # atyp_*:             Address type
+    # auth_*:             Authorication version
+    variable const
+    array set const {
+	ver                 \x05
+	auth_no             \x00
+	auth_gssapi         \x01
+	auth_userpass       \x02
+	nomatchingmethod    \xFF
+	cmd_connect         \x01
+	cmd_bind            \x02
+	rsv                 \x00
+	atyp_ipv4           \x01
+	atyp_domainname     \x03
+	atyp_ipv6           \x04
+	rsp_succeeded       \x00
+	rsp_failure         \x01
+	rsp_notallowed      \x02
+	rsp_netunreachable  \x03
+	rsp_hostunreachable \x04
+	rsp_refused         \x05
+	rsp_expired         \x06
+	rsp_cmdunsupported  \x07
+	rsp_addrunsupported \x08
+    }
+
+    # Practical when mapping errors to error codes.
+    variable iconst
+    array set iconst {
+	0    rsp_succeeded
+	1    rsp_failure
+	2    rsp_notallowed
+	3    rsp_netunreachable
+	4    rsp_hostunreachable
+	5    rsp_refused
+	6    rsp_expired
+	7    rsp_cmdunsupported
+	8    rsp_addrunsupported
+    }
+
+    variable ipv4_num_re {([0-9]{1,3}\.){3}[0-9]{1,3}}
+    variable ipv6_num_re {([0-9a-fA-F]{4}:){7}[0-9a-fA-F]{4}}
+
+    variable msg
+    array set msg {
+	1 "General SOCKS server failure"
+	2 "Connection not allowed by ruleset"
+	3 "Network unreachable"
+	4 "Host unreachable"
+	5 "Connection refused"
+	6 "TTL expired"
+	7 "Command not supported"
+	8 "Address type not supported"
+    }
+
+    variable debug 0
+    variable uid 0
+}
+
+# socks5::connect --
+#
+#       Negotiates with a SOCKS server.
+#
+# Arguments:
+#       sock:       an open socket token to the SOCKS server
+#       addr:       the peer address, not SOCKS server
+#       port:       the peer's port number
+#       args:
+#               -command    tclProc {status socket}
+#               -username   username
+#               -password   password
+#               -timeout    millisecs (default 60000)
+#
+# Results:
+#       The connect socket or error if no -command, else empty string.
+#
+# Side effects:
+#	Socket is prepared for data transfer.
+#	If -command specified, the callback tclProc is called with
+#	status OK and socket or ERROR and error message.
+
+proc socks5::connect {sock addr port args} {
+    variable msg
+    variable const
+    variable uid
+
+    Debug 2 "socks5::init $addr $port $args"
+
+    # Initialize the state variable, an array.  We'll return the
+    # name of this array as the token for the transaction.
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    array set state {
+	-password         ""
+	-timeout          60000
+	-username         ""
+	async             0
+	auth              0
+	bnd_addr          ""
+	bnd_port          ""
+	state             ""
+	status            ""
+    }
+    array set state [list     \
+      addr          $addr     \
+      port          $port     \
+      sock          $sock]
+    array set state $args
+
+    if {[string length $state(-username)] ||  \
+      [string length $state(-password)]} {
+	set state(auth) 1
+    }
+    if {[info exists state(-command)] && [string length $state(-command)]} {
+	set state(async) 1
+    }
+    if {$state(auth)} {
+	set methods  "$const(auth_no)$const(auth_userpass)"
+    } else {
+	set methods  "$const(auth_no)"
+    }
+    set nmethods [binary format c [string length $methods]]
+
+    fconfigure $sock -translation {binary binary} -blocking 0
+    fileevent $sock writable {}
+
+    Debug 2 "\tsend: ver nmethods methods"
+
+    # Request authorization methods
+    if {[catch {
+	puts -nonewline $sock "$const(ver)$nmethods$methods"
+	flush $sock
+    } err]} {
+	if {$state(async)} {
+	    after idle [list $state(-command) ERROR network-failure]
+	    Free $token
+	    return
+	} else {
+	    Free $token
+	    return -code error $err
+	}
+    }
+
+    # Setup timeout timer.
+    set state(timeoutid)  \
+	[after $state(-timeout) [namespace current]::Timeout $token]
+
+    fileevent $sock readable  \
+	[list [namespace current]::ResponseMethod $token]
+
+    if {$state(async)} {
+	return
+    } else {
+	# We should not return from this proc until finished!
+	vwait $token\(status)
+
+	set status $state(status)
+	set sock $state(sock)
+
+	Free $token
+
+	if {[string equal $status OK]} {
+	    return $sock
+	} else {
+	    return -code error $sock
+	}
+    }
+}
+
+# socks5::ResponseMethod --
+#
+#	Receive the reply from a proxy and choose authorization method.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	The negotiation is finished with error or continues with chosen
+#	method.
+
+proc socks5::ResponseMethod {token} {
+    variable $token
+    variable const
+    upvar 0 $token state
+
+    Debug 2 "socks5::ResponseMethod"
+
+    set sock $state(sock)
+
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    set serv_ver ""
+    set method $const(nomatchingmethod)
+    binary scan $data cc serv_ver smethod
+    Debug 2 "\tserv_ver=$serv_ver, smethod=$smethod"
+
+    if {![string equal $serv_ver 5]} {
+	Finish $token err_version
+	return
+    }
+
+    if {[string equal $smethod 0]} {
+	# Now, request address and port.
+	Request $token
+    } elseif {[string equal $smethod 2]} {
+	# User/Pass authorization required
+	if {$state(auth) == 0} {
+	    Finish $token err_authorization_required
+	    return
+	}
+
+	# Username & Password length (binary 1 byte)
+	set ulen [binary format c [string length $state(-username)]]
+	set plen [binary format c [string length $state(-password)]]
+
+	Debug 2 "\tsend: auth_userpass ulen -username plen -password"
+	if {[catch {
+	    puts -nonewline $sock  \
+		"$const(auth_userpass)$ulen$state(-username)$plen$state(-password)"
+	    flush $sock
+	} err]} {
+	    Finish $token network-failure
+	    return
+	}
+
+	fileevent $sock readable  \
+	    [list [namespace current]::ResponseAuth $token]
+    } else {
+	Finish $token err_unsupported_method
+    }
+    return
+}
+
+# socks5::ResponseAuth --
+#
+#	Receive the authorization reply from a proxy.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	The negotiation is finished with error or continues with address and
+#	port request.
+
+proc socks5::ResponseAuth {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::ResponseAuth"
+
+    set sock $state(sock)
+
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+
+    set auth_ver -1
+    set status -1
+    binary scan $data cc auth_ver status
+    Debug 2 "\tauth_ver=$auth_ver, status=$status"
+
+    if {![string equal $auth_ver 1]} {
+	Finish $token err_authentication_unsupported
+	return
+    }
+    if {![string equal $status 0]} {
+	Finish $token err_authorization
+	return
+    }
+
+    # Now, request address and port.
+    Request $token
+    return
+}
+
+# socks5::Request --
+#
+#	Request connect to specified address and port.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	The negotiation is finished with error or continues with address and
+#	port request.
+
+proc socks5::Request {token} {
+    variable $token
+    variable const
+    variable ipv4_num_re
+    variable ipv6_num_re
+    upvar 0 $token state
+
+    Debug 2 "socks5::Request"
+
+    set sock $state(sock)
+
+    # Network byte-ordered port (2 binary-bytes, short)
+    set bport [binary format S $state(port)]
+
+    # Figure out type of address given to us.
+    if {[regexp $ipv4_num_re $state(addr)]} {
+	Debug 2 "\tipv4"
+
+	# IPv4 numerical address.
+	set atyp_addr_port $const(atyp_ipv4)
+    	foreach i [split $state(addr) .] {
+	    append atyp_addr_port [binary format c $i]
+	}
+	append atyp_addr_port $bport
+    } elseif {[regexp $ipv6_num_re $state(addr)]} {
+	# todo
+    } else {
+	Debug 2 "\tdomainname"
+
+	# Domain name.
+	# Domain length (binary 1 byte)
+	set dlen [binary format c [string length $state(addr)]]
+	set atyp_addr_port \
+	  "$const(atyp_domainname)$dlen$state(addr)$bport"
+    }
+
+    # We send request for connect
+    Debug 2 "\tsend: ver cmd_connect rsv atyp_domainname dlen addr port"
+    set aconst "$const(ver)$const(cmd_connect)$const(rsv)"
+    if {[catch {
+	puts -nonewline $sock "$aconst$atyp_addr_port"
+	flush $sock
+    } err]} {
+	Finish $token network-failure
+	return
+    }
+
+    fileevent $sock readable  \
+	[list [namespace current]::Response $token]
+    return
+}
+
+# socks5::Response --
+#
+#	Receive the final reply from a proxy and finish the negotiations.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	The negotiation is finished with either success or error.
+
+proc socks5::Response {token} {
+    variable $token
+    upvar 0 $token state
+    variable iconst
+
+    Debug 2 "socks5::Response"
+
+    set sock $state(sock)
+    fileevent $sock readable {}
+
+    # Start by reading ver+cmd+rsv.
+    if {[catch {read $sock 3} data] || [eof $sock]} {
+	Finish $token network-failure
+	return
+    }
+    set serv_ver ""
+    set rep ""
+    binary scan $data ccc serv_ver rep rsv
+
+    if {![string equal $serv_ver 5]} {
+	Finish $token err_version
+	return
+    }
+    if {$rep == 0} {
+	# OK
+    } elseif {[info exists iconst($rep)]} {
+	Finish $token $iconst($rep)
+	return
+    } else {
+	Finish $token err_unknown
+	return
+    }
+
+    # Now parse the variable length atyp+addr+host.
+    if {[catch {ParseAtypAddr $token addr port} err]} {
+	Finish $token $err
+	return
+    }
+
+    # Store in our state array.
+    set state(bnd_addr) $addr
+    set state(bnd_port) $port
+
+    # And finally let the client know that the bytestream is set up.
+    Finish $token
+    return
+}
+
+# socks5::ParseAtypAddr --
+#
+#	Receive and parse destination address type and IP or name.
+#
+# Arguments:
+#	token	    A connection token.
+#	addrVar	    A variable for destination address.
+#	portVar	    A variable for destination port.
+#
+# Result:
+#	An empty string or error if address and port can't be parsed.
+#
+# Side effects:
+#	The address type and IP or name is read from the socket.
+
+proc socks5::ParseAtypAddr {token addrVar portVar} {
+    variable $token
+    variable const
+    upvar 0 $token state
+    upvar $addrVar addr
+    upvar $portVar port
+
+    Debug 2 "socks5::ParseAtypAddr"
+
+    set sock $state(sock)
+
+    # Start by reading atyp.
+    if {[catch {read $sock 1} data] || [eof $sock]} {
+	return -code error network-failure
+    }
+    set atyp ""
+    binary scan $data c atyp
+    Debug 2 "\tatyp=$atyp"
+
+    # Treat the three address types in order.
+    switch -- $atyp {
+	1 {
+	    if {[catch {read $sock 6} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    binary scan $data ccccS i0 i1 i2 i3 port
+	    set addr ""
+	    foreach n [list $i0 $i1 $i2 $i3] {
+		# Translate to unsigned!
+		append addr [expr ( $n + 0x100 ) % 0x100]
+		if {$n <= 2} {
+		    append addr .
+		}
+	    }
+	    # Translate to unsigned!
+	    set port [expr ( $port + 0x10000 ) % 0x10000]
+	}
+	3 {
+	    if {[catch {read $sock 1} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    binary scan $data c len
+	    Debug 2 "\tlen=$len"
+	    set len [expr ( $len + 0x100 ) % 0x100]
+	    if {[catch {read $sock $len} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    set addr $data
+	    Debug 2 "\taddr=$addr"
+	    if {[catch {read $sock 2} data] || [eof $sock]} {
+		return -code error network-failure
+	    }
+	    binary scan $data S port
+	    # Translate to unsigned!
+	    set port [expr ( $port + 0x10000 ) % 0x10000]
+	    Debug 2 "\tport=$port"
+	}
+	4 {
+	    # todo
+	}
+	default {
+	    return -code error err_unknown_address_type
+	}
+    }
+}
+
+proc socks5::GetIpAndPort {token} {
+    variable $token
+    upvar 0 $token state
+    return [list $state(bnd_addr) $state(bnd_port)]
+}
+
+# socks5::Timeout --
+#
+#	This proc is called in case of timeout.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A proxy negotiation is finished with error.
+
+proc socks5::Timeout {token} {
+    Finish $token timeout
+    return
+}
+
+# socks5::Free --
+#
+#	Frees a connection token.
+#
+# Arguments:
+#	token	    A connection token.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	A connection token and its state informationa are destroyed.
+
+proc socks5::Free {token} {
+    variable $token
+    upvar 0 $token state
+
+    catch {after cancel $state(timeoutid)}
+    catch {unset state}
+}
+
+# socks5::Finish --
+#
+#	Finishes a negotiation process.
+#
+# Arguments:
+#	token	    A connection token.
+#	errormsg    (optional) error message.
+#
+# Result:
+#	An empty string.
+#
+# Side effects:
+#	If connection is asynchronous then a callback is executed.
+#	Otherwise state(status) is set to allow https::connect to return
+#	with either success or error.
+
+proc socks5::Finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::Finish errormsg=$errormsg"
+
+    catch {after cancel $state(timeoutid)}
+
+    if {$state(async)} {
+	# In case of asynchronous connection we do the cleanup.
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    uplevel #0 $state(-command) [list ERROR $errormsg]
+	} else {
+	    uplevel #0 $state(-command) [list OK $state(sock)]
+	}
+	Free $token
+    } else {
+	# Otherwise we trigger state(status).
+	if {[string length $errormsg]} {
+	    catch {close $state(sock)}
+	    set state(sock) $errormsg
+	    set state(status) ERROR
+	} else {
+	    set state(status) OK
+	}
+    }
+    return
+}
+
+# socks5::serverinit --
+#
+#       The SOCKS5 server. Negotiates with a SOCKS5 client.
+#       Sets up bytestreams between client and DST.
+#
+# Arguments:
+#       sock:       socket connected to the servers socket
+#       ip:         ip address
+#       port:       it's port number
+#       command:    tclProc for callabcks {token type args}
+#       args:
+#               -blocksize     bytes
+#               -bytestream    boolean
+#               -opendstsocket boolean
+#               -timeout       millisecs
+#
+# Results:
+#       token.
+
+proc socks5::serverinit {sock ip port command args} {
+    variable msg
+    variable const
+    variable uid
+
+    Debug 2 "socks5::serverinit"
+
+    # Initialize the state variable, an array.  We'll return the
+    # name of this array as the token for the transaction.
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar 0 $token state
+
+    array set state {
+	-blocksize        8192
+	-bytestream       1
+	-opendstsocket    1
+	-timeout          60000
+	auth              0
+	state             ""
+	status            ""
+    }
+    array set state [list        \
+      command       $command     \
+      sock          $sock]
+    array set state $args
+
+    fconfigure $sock -translation {binary binary} -blocking 0
+    fileevent $sock writable {}
+
+    # Start by reading the method stuff.
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set ver ""
+    set method $const(nomatchingmethod)
+    binary scan $data cc ver nmethods
+    set nmethods [expr ( $nmethods + 0x100 ) % 0x100]
+    Debug 2 "\tver=$ver, nmethods=$nmethods"
+
+    # Error checking. Must have either noauth or userpasswdauth.
+    if {![string equal $ver 5]} {
+	serv_finish $token "Socks server isn't version 5!"
+	return
+    }
+    for {set i 0} {$i < $nmethods} {incr i} {
+	if {[catch {read $sock 1} data] || [eof $sock]} {
+	    serv_finish $token network-failure
+	    return
+	}
+	binary scan $data c method
+	set method [expr ( $method + 0x100 ) % 0x100]
+	Debug 2 "\tmethod=$method"
+	if {[string equal $method 0]} {
+	    set noauthmethod 1
+	} elseif {[string equal $method 2]} {
+	    set userpasswdmethod 1
+	}
+    }
+    set isok 1
+    if {[info exists userpasswdmethod]} {
+	set ans "$const(ver)$const(auth_userpass)"
+	set state(auth) 1
+    } elseif {[info exists noauthmethod]} {
+	set ans "$const(ver)$const(auth_no)"
+    } else {
+	set ans "$const(ver)$const(nomatchingmethod)"
+	set isok 0
+    }
+
+    Debug 2 "\tsend: ver method"
+    if {[catch {
+	puts -nonewline $sock $ans
+	flush $sock
+    } err]} {
+	serv_finish $token $err
+	return
+    }
+    if {!$isok} {
+	serv_finish $token "Unrecognized method requested by client"
+	return
+    }
+
+    if {$state(auth)} {
+	fileevent $sock readable  \
+	  [list [namespace current]::serv_auth $token]
+    } else {
+	fileevent $sock readable  \
+	  [list [namespace current]::serv_request $token]
+    }
+    return $token
+}
+
+proc socks5::serv_auth {token} {
+    variable $token
+    variable const
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_auth"
+
+    set sock $state(sock)
+    fileevent $sock readable {}
+
+    if {[catch {read $sock 2} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set auth_ver ""
+    set method $const(nomatchingmethod)
+    binary scan $data cc auth_ver ulen
+    set ulen [expr ( $ulen + 0x100 ) % 0x100]
+    Debug 2 "\tauth_ver=$auth_ver, ulen=$ulen"
+    if {![string equal $auth_ver 2]} {
+	serv_finish $token "Wrong authorization method"
+	return
+    }
+    if {[catch {read $sock $ulen} data] || [eof $sock]} {
+	return -code error network-failure
+    }
+    set state(username) $data
+    Debug 2 "\tusername=$data"
+    if {[catch {read $sock 1} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    binary scan $data c plen
+    set plen [expr ( $plen + 0x100 ) % 0x100]
+    Debug 2 "\tplen=$plen"
+    if {[catch {read $sock $plen} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set state(password) $data
+    Debug 2 "\tpassword=$data"
+
+    set ans [uplevel #0 $state(command) [list $token authorize \
+      -username $state(username) -password $state(password)]]
+    if {!$ans} {
+	catch {
+	    puts -nonewline $state(sock) "\x00\x01"
+	}
+	serv_finish $token notauthorized
+	return
+    }
+
+    # Write auth response.
+    if {[catch {
+	puts -nonewline $sock "\x01\x00"
+	flush $sock
+    } err]} {
+	serv_finish $token $err
+	return
+    }
+    fileevent $sock readable  \
+      [list [namespace current]::serv_request $token]
+}
+
+proc socks5::serv_request {token} {
+    variable $token
+    variable const
+    variable msg
+    variable ipv4_num_re
+    variable ipv6_num_re
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_request"
+
+    set sock $state(sock)
+
+    # Start by reading ver+cmd+rsv.
+    if {[catch {read $sock 3} data] || [eof $sock]} {
+	serv_finish $token network-failure
+	return
+    }
+    set ver ""
+    set cmd ""
+    set rsv ""
+    binary scan $data ccc ver cmd rsv
+    Debug 2 "\tver=$ver, cmd=$cmd, rsv=$rsv"
+
+    if {![string equal $ver 5]} {
+	serv_finish $token "Socks server isn't version 5!"
+	return
+    }
+    if {![string equal $cmd 1]} {
+	serv_finish $token "Unsuported CMD, must be CONNECT"
+	return
+    }
+
+    # Now parse the variable length atyp+addr+host.
+    if {[catch {ParseAtypAddr $token addr port} err]} {
+	serv_finish $token $err
+	return
+    }
+
+    # Store in our state array.
+    set state(dst_addr) $addr
+    set state(dst_port) $port
+
+    # Init the SOCKS connection to dst if wanted. Else???
+    if {$state(-opendstsocket)} {
+	if {[catch {socket -async $addr $port} sock_dst]} {
+	    serv_finish $token network-failure
+	    return
+	}
+	set state(sock_dst) $sock_dst
+
+	# Setup timeout timer.
+	set state(timeoutid)  \
+	  [after $state(-timeout) [namespace current]::ServTimeout $token]
+	fileevent $sock_dst writable  \
+	  [list [namespace current]::serv_dst_connect $token]
+    } else {
+
+	# ???
+	uplevel #0 $state(command) [list $token reply]
+    }
+}
+
+proc socks5::serv_dst_connect {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_dst_connect"
+    fileevent $state(sock_dst) writable {}
+    after cancel $state(timeoutid)
+
+    set sock_dst $state(sock_dst)
+    if {[eof $sock_dst]} {
+	serv_finish $token network-failure
+	return
+    }
+
+    if {[catch {
+	fconfigure $sock_dst -translation {binary binary} -blocking 0
+	foreach {bnd_ip bnd_addr bnd_port} [fconfigure $sock_dst -sockname] \
+	  break
+    } err]} {
+	Debug 2 "\tfconfigure failed: $err"
+	serv_finish $token network-failure
+	return
+    }
+    array set state [list bnd_ip $bnd_ip bnd_addr $bnd_addr bnd_port $bnd_port]
+    serv_reply $token
+}
+
+proc socks5::serv_reply {token} {
+    variable $token
+    variable const
+    upvar 0 $token state
+
+    Debug 2 "socks5:serv_reply"
+    set sock $state(sock)
+    set bnd_addr $state(bnd_addr)
+    set bnd_port $state(bnd_port)
+    Debug 2 "\tbnd_addr=$bnd_addr, bnd_port=$bnd_port"
+
+    set aconst "$const(ver)$const(rsp_succeeded)$const(rsv)"
+
+    # Domain length (binary 1 byte)
+    set dlen [binary format c [string length $bnd_addr]]
+
+    # Network byte-ordered port (2 binary-bytes, short)
+    set bport [binary format S $bnd_port]
+    set atyp_addr_port \
+      "$const(atyp_domainname)$dlen$bnd_addr$bport"
+
+    # We send SOCKS server's reply to client.
+    Debug 2 "\tsend: ver rep rsv atyp_domainname dlen bnd_addr bnd_port"
+    if {[catch {
+	puts -nonewline $sock "$aconst$atyp_addr_port"
+	flush $sock
+    } err]} {
+	serv_finish $token $err
+	return
+    }
+
+    # New we are ready to stream data if wanted.
+    if {$state(-bytestream)} {
+	establish_bytestreams $token
+    } else {
+	# ???
+	serv_finish $token
+    }
+}
+
+proc socks5::establish_bytestreams {token} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::establish_bytestreams"
+    set sock $state(sock)
+    set sock_dst $state(sock_dst)
+
+    # Forward client stream to dst.
+    fileevent $sock readable  \
+      [list [namespace current]::read_stream $token $sock $sock_dst]
+
+    # Forward dst stream to client.
+    fileevent $sock_dst readable  \
+      [list [namespace current]::read_stream $token $sock_dst $sock]
+}
+
+proc socks5::read_stream {token in out} {
+    variable $token
+    upvar 0 $token state
+
+    set primary [string equal $state(sock) $in]
+    Debug 3 "::socks5::read_stream primary=$primary: in=$in, out=$out"
+
+    # If any of client (sock) or dst (sock_dst) closes down we shall
+    # close down everthing.
+    # Only client or dst can determine if a close down is premature.
+
+    if {[catch {eof $in} iseof] || $iseof} {
+	serv_finish $token
+    } elseif {[catch {eof $out} iseof] || $iseof} {
+	serv_finish $token
+    } elseif {[catch {read $in} data]} {
+	serv_finish $token network-failure
+    } else {
+
+	# We could wait here (in the event loop) for channel to be writable
+	# to avoid any blocking...
+	# BUT, this would keep $data in memory for a while which is a bad idee.
+	if {0} {
+	    fileevent $out writable  \
+	      [list [namespace current]::stream_writeable $token $primary]
+	    vwait $token\(writetrigger${primary})
+	}
+	if {[catch {puts -nonewline $out $data; flush $out}]} {
+	    serv_finish $token network-failure
+	}
+    }
+}
+
+proc socks5::stream_writeable {token primary} {
+    variable $token
+    upvar 0 $token state
+
+    incr state(writetrigger${primary})
+}
+
+proc socks5::serv_finish {token {errormsg ""}} {
+    variable $token
+    upvar 0 $token state
+
+    Debug 2 "socks5::serv_finish"
+    if {$state(-bytestream)} {
+	catch {close $state(sock)}
+	catch {close $state(sock_dst)}
+    }
+    if {[string length $errormsg]} {
+	uplevel #0 $state(command) [list $token $errormsg]
+    } else {
+	uplevel #0 $state(command) [list $token ok]
+    }
+    unset state
+}
+
+#       Just a trigger for vwait.
+
+proc socks5::readable {token} {
+    variable $token
+    upvar 0 $token state
+
+    incr state(trigger)
+}
+
+proc socks5::ServTimeout {token} {
+    variable $token
+    upvar 0 $token state
+
+    serv_finish $token timeout
+}
+
+proc socks5::Debug {num str} {
+    variable debug
+    if {$num <= $debug} {
+	puts $str
+    }
+}
+
+# Test code...
+
+if {0} {
+
+    # Server
+    proc serv_cmd {token status} {
+	puts "server: token=$token, status=$status"
+	switch -- $status {
+	    ok {
+
+	    }
+	    authorize {
+		# Here we should check that the username and password is ok.
+		return 1
+	    }
+	    default {
+		puts "error $status"
+	    }
+	}
+    }
+    proc server_connect {sock ip port} {
+	fileevent $sock readable  \
+	  [list socks5::serverinit $sock $ip $port serv_cmd]
+    }
+    socket -server server_connect 1080
+}
+
+if {0} {
+    # Client
+    proc cb {status socket} {
+	puts "client: status=$status, socket=$socket"
+	if {$status eq "OK"} {
+	    fconfigure $socket -buffering none
+	    close $socket
+	}
+    }
+    proc dump {} {
+	puts "dump:"
+    }
+    set s [socket 192.168.0.1 1080]
+    #socks5::connect $s jabber.ru 5222 -command cb
+    socks5::connect $s jabber.ru 5222 -command cb -username xxx -password xxx
+}
+


Property changes on: trunk/tkabber/jabberlib-tclxml/socks5.tcl
___________________________________________________________________
Name: svn:keywords
   + Author Date Id Revision
Name: svn:eol-style
   + native

Modified: trunk/tkabber/jabberlib-tclxml/transports.tcl
===================================================================
--- trunk/tkabber/jabberlib-tclxml/transports.tcl	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/jabberlib-tclxml/transports.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -10,221 +10,15 @@
     return $capabilities
 }
 
-namespace eval transport::proxy {
-    variable capabilities [list none http]
-}
+######################################################################
 
+# TODO
+namespace eval transport::proxy {}
+
 proc transport::proxy::capabilities {} {
-    variable capabilities
-    return $capabilities
+    return [list none socks4 socks5 https]
 }
 
-# Connect without proxy
-namespace eval transport::proxy::none {}
-
-proc transport::proxy::none::connect {connid server port args} {
-    return [socket $server $port]
-}
-
-package require base64
-
-# Connect with HTTP proxy
-namespace eval transport::proxy::http {
-    if {[catch {package require ntlm}]} {
-	set auth [list basic]
-    } else {
-	set auth [list basic ntlm]
-    }
-}
-
-proc transport::proxy::http::connect {connid server port args} {
-    variable auth
-
-    set useragent ""
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -proxyhost { set proxyhost $val }
-	    -proxyport { set proxyport $val }
-	    -proxyusername { set username $val }
-	    -proxypassword { set password $val }
-	    -proxyuseragent { set useragent $val}
-	}
-    }
-
-    set sock [socket $proxyhost $proxyport]
-    puts_connect_query $sock $server $port $useragent
-    set code [read_proxy_answer $sock result]
-
-    if {$code >= 200 && $code < 300} {
-	while {![cequal [gets $sock] ""]} { }
-	return $sock
-    } elseif {$code == 407} {
-	set content_length -1
-	set method basic
-	while {![cequal [set header [gets $sock]] ""]} {
-	    switch -- [http_header_name $header] {
-		proxy-authenticate {
-		    set body [http_header_body $header]
-		    if {[string equal -nocase -length 4 $body "NTLM"]} {
-			if {[lsearch -exact $auth ntlm] >= 0} {
-			    set method ntlm
-			}
-		    }
-		}
-		content-length {
-		    set content_length [string trim [http_header_body $header]]
-		}
-		default { }
-	    }
-	}
-
-	read_proxy_junk $sock $content_length
-	close $sock
-	
-	set sock [socket $proxyhost $proxyport]
-	if {[catch {connect:$method \
-			$sock $server $port $useragent $username $password} \
-		 result]} {
-	    close $sock
-	    error "HTTP proxy returned: $result"
-	} else {
-	    return $sock
-	}
-    } else {
-	close $sock
-	error "HTTP proxy returned: $result"
-    }
-}
-
-proc transport::proxy::http::connect:basic {sock server port useragent username password} {
-    set auth [string map {\n {}} \
-		   [base64::encode [encoding convertto "$username:$password"]]]
-
-    puts_connect_query $sock $server $port $useragent "Basic $auth"
-    set code [read_proxy_answer $sock result]
-
-    if {$code >= 200 && $code < 300} {
-	while {![cequal [gets $sock] ""]} { }
-	return $sock
-    } else {
-	return -code error $result
-    }
-}
-
-proc transport::proxy::http::connect:ntlm {sock server port useragent username password} {
-    set domain ""
-    set host [info hostname]
-
-    # if username is domain/username or domain\username
-    # then set domain and username
-    regexp {(\w+)[\\/](.*)} $username -> domain username
-
-    set token [NTLM::new -domain $domain \
-			 -host $host \
-			 -username $username \
-			 -password $password]
-    set message1 [$token type1_message]
-
-    puts_connect_query $sock $server $port $useragent "NTLM $message1"
-    set code [read_proxy_answer $sock result]
-
-    if {$code >= 200 && $code < 300} {
-	while {![cequal [gets $sock] ""]} { }
-	return $sock
-    } elseif {$code != 407} {
-	return -code error $result
-    }
-    
-    set content_length -1
-    set message2 ""
-    while {![string equal [set header [gets $sock]] ""]} {
-	switch -- [http_header_name $header] {
-	    proxy-authenticate {
-		set body [http_header_body $header]
-		if {[string equal -length 5 $body "NTLM "]} {
-		    set message2 [string range $body 5 end]
-		}
-	    }
-	    content-length {
-		set content_length [string trim [http_header_body $header]]
-	    }
-	    default { }
-	}
-    }
-
-    read_proxy_junk $sock $content_length
-
-    $token parse_type2_message -message $message2
-    set message3 [$token type3_message]
-    $token free
-
-    puts_connect_query $sock $server $port $useragent "NTLM $message3"
-    set code [read_proxy_answer $sock result]
-
-    if {$code >= 200 && $code < 300} {
-	while {![cequal [gets $sock] ""]} { }
-	return $sock
-    } else {
-	return -code error $result
-    }
-}
-
-proc transport::proxy::http::puts_connect_query {sock server port useragent {auth ""}} {
-    fconfigure $sock -buffering line -translation auto
-
-    puts $sock "CONNECT $server:$port HTTP/1.1"
-    puts $sock "Proxy-Connection: keep-alive"
-    if {$useragent != ""} {
-	puts $sock "User-Agent: $useragent"
-    }
-    if {$auth != ""} {
-	puts $sock "Proxy-Authorization: $auth"
-    }
-    puts $sock ""
-    
-}
-
-proc transport::proxy::http::read_proxy_answer {sock resultvar} {
-    variable proxy_readable
-    upvar $resultvar result
-
-    fileevent $sock readable \
-	[list set [namespace current]::proxy_readable($sock) {}]
-    vwait [namespace current]::proxy_readable($sock)
-    fileevent $sock readable {}
-    unset proxy_readable($sock)
-
-    set result [gets $sock]
-    set code [lindex [split $result { }] 1]
-    
-    if {[string is integer -strict $code]} {
-	return $code
-    } else {
-	return -code error $result
-    }
-}
-
-proc transport::proxy::http::read_proxy_junk {sock length} {
-    fconfigure $sock -buffering none -translation binary
-    if {$length != -1} {
-	read $sock $length
-    } else {
-	read $sock
-    }
-}
-
-proc transport::proxy::http::http_header_name {header} {
-    set hlist [split $header ":"]
-    return [string tolower [lindex $hlist 0]]
-}
-
-proc transport::proxy::http::http_header_body {header} {
-    set hlist [split $header ":"]
-    set body [join [lrange $hlist 1 end] ":"]
-    return [string trim $body]
-}
-
-
 ######################################################################
 #
 # TCP Socket Support
@@ -236,15 +30,7 @@
 proc transport::tcp::connect {connid server port args} {
     variable lib
 
-    set proxytype none
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -proxytype { set proxytype $val }
-	}
-    }
-
-    set sock [eval [list [namespace parent]::proxy::${proxytype}::connect \
-			 $connid $server $port] $args]
+    set sock [eval [list autoconnect::socket $server $port] $args]
     fconfigure $sock -blocking 0 -buffering none \
 	       -translation auto -encoding utf-8
     set lib($connid,socket) $sock
@@ -342,16 +128,8 @@
 proc transport::zlib::connect {connid server port args} {
     variable lib
 
-    set proxytype none
-    foreach {opt val} $args {
-	switch -- $opt {
-	    -proxytype { set proxytype $val }
-	}
-    }
+    set sock [eval [list autoconnect::socket $server $port] $args]
 
-    set sock [eval [list [namespace parent]::proxy::${proxytype}::connect \
-			 $connid $server $port] $args]
-
     set lib($connid,socket) $sock
     import $connid
 
@@ -442,11 +220,9 @@
 proc transport::tls::connect {connid server port args} {
     variable lib
 
-    set proxytype none
     set tlsargs {}
     foreach {opt val} $args {
 	switch -- $opt {
-	    -proxytype { set proxytype $val }
 	    -cacertstore {
 		if {$val != ""} {
 		    if {[file isdirectory $val]} {
@@ -465,8 +241,7 @@
 	}
     }
 
-    set sock [eval [list [namespace parent]::proxy::${proxytype}::connect \
-			 $connid $server $port] $args]
+    set sock [eval [list autoconnect::socket $server $port] $args]
 
     fconfigure $sock -encoding binary -translation binary
 

Modified: trunk/tkabber/login.tcl
===================================================================
--- trunk/tkabber/login.tcl	2007-07-12 14:33:19 UTC (rev 1155)
+++ trunk/tkabber/login.tcl	2007-07-15 13:53:33 UTC (rev 1156)
@@ -19,7 +19,7 @@
     set have_sasl 0
 }
 
-if {[lcontain [jlib::capabilities proxy] http]} {
+if {[llength [jlib::capabilities proxy]] > 1} {
     set have_proxy 1
 } else {
     set have_proxy 0
@@ -103,25 +103,36 @@
 }
 
 if {$have_proxy} {
-    custom::defvar loginconf(useproxy) 0 \
-	[::msgcat::mc "Use HTTP proxy to connect."] \
-	-group Login -type boolean
-    custom::defvar loginconf(httpproxy) "localhost" \
+    set values {}
+    foreach type [jlib::capabilities proxy] {
+	switch -- $type {
+	    none   {lappend values none   [::msgcat::mc "None"]}
+	    socks4 {lappend values socks4 [::msgcat::mc "SOCKS4a"]}
+	    socks5 {lappend values socks5 [::msgcat::mc "SOCKS5"]}
+	    https  {lappend values https  [::msgcat::mc "HTTPS"]}
+	}
+    }
+    custom::defvar loginconf(proxy) none \
+	[::msgcat::mc "Proxy type to connect."] \
+	-group Login -type options \
+	-values $values
+    custom::defvar loginconf(proxyhost) "localhost" \
 	[::msgcat::mc "HTTP proxy address."] \
 	-group Login -type string
-    custom::defvar loginconf(httpproxyport) 3128 \
+    custom::defvar loginconf(proxyport) 3128 \
 	[::msgcat::mc "HTTP proxy port."] \
 	-group Login -type integer
-    custom::defvar loginconf(httplogin) "" \
+    custom::defvar loginconf(proxyusername) "" \
 	[::msgcat::mc "HTTP proxy username."] \
 	-group Login -type string
-    custom::defvar loginconf(httppassword) "" \
+    custom::defvar loginconf(proxypassword) "" \
 	[::msgcat::mc "HTTP proxy password."] \
 	-group Login -type password
-    custom::defvar loginconf(httpuseragent) \
+    custom::defvar loginconf(proxyuseragent) \
 	"Mozilla/4.0 (compatible; MSIE 6.0;\
-$::tcl_platform(os) $::tcl_platform(osVersion))" \
-	[::msgcat::mc "User-Agent string."] -group Login -type string
+	 $::tcl_platform(os) $::tcl_platform(osVersion))" \
+	[::msgcat::mc "User-Agent string."] \
+	-group Login -type string
 }
 
 custom::defvar loginconf(usealtserver) 0 \
@@ -299,13 +310,13 @@
 	lappend args -usesasl $lc(usesasl)
     }
 
-    if {$have_proxy && $lc(useproxy)} {
-	lappend args -proxytype http
-	lappend args -proxyhost $lc(httpproxy)
-	lappend args -proxyport $lc(httpproxyport)
-	lappend args -proxyusername $lc(httplogin)
-	lappend args -proxypassword $lc(httppassword)
-	lappend args -proxyuseragent $lc(httpuseragent)
+    if {$have_proxy && ($lc(proxy) != "none")} {
+	lappend args -proxy $lc(proxy)
+	lappend args -proxyhost $lc(proxyhost)
+	lappend args -proxyport $lc(proxyport)
+	lappend args -proxyusername $lc(proxyusername)
+	lappend args -proxypassword $lc(proxypassword)
+	lappend args -proxyuseragent $lc(proxyuseragent)
     }
 
     set ascii_server [idna::domain_toascii $lc(server)]



More information about the Tkabber-dev mailing list