# tlspipe.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
 #
 # Test sampler to check the usage for opening a SSL link through an
 # authenticating HTTP proxy server.
 #
 # $Id: 9411,v 1.8 2004-11-17 07:00:23 jcw Exp $
 
 package require tls  1.4;               # http://tls.sf.net/
 package require http 2;                 # http://tcl.sf.net/
 package require uri  1;                 # http://tcllib.sf.net/
 package require base64;                 # http://tcllib.sf.net/
 
 namespace eval tlspipe {
     variable uid
     if {![info exists uid]} {set uid 0}
 
     variable opts
     if {![info exists opts]} {
         array set opts {
             targetUrl    http://max.tclers.tk:443
             serverAddr   127.0.0.1
             serverPort   8080
             proxyHost    {}
             proxyPort    {}
             proxyAuth    {}
             proxyUser    {}
             proxyPass    {}
             buffering    none
             translation  binary
         }
         if {[info exists ::env(http_proxy)]} {
             if {![catch {array set URL [uri::split $::env(http_proxy)]}]} {
                 set opts(proxyHost) $URL(host)
                 set opts(proxyPort) $URL(port)
                 unset URL
             }
             if {[info exists ::env(http_proxy_user)]} {
                 set opts(proxyUser) $::env(http_proxy_user)
             }
             if {[info exists ::env(http_proxy_pass)]} {
                 set opts(proxyPass) $::env(http_proxy_pass)
             }
         }
         set opts(userAgent) "Mozilla/4.0\
                ([string totitle $::tcl_platform(platform)];\
                $::tcl_platform(os)) http/[package provide http]\
                tlspipe/1.0"
     }
 
     variable NonPrinting
     if {![info exists NonPrinting]} {
         for {set n 0} {$n < 256} {incr n} {
             if {$n < 32 || $n > 127} {
                 append NonPrinting [format "\\x%x . " $n]
             }
         }
     }
 
 }
 
 proc tlspipe::Log {msg} {
     puts stderr $msg
 }
 
 proc tlspipe::Accept {chan clientAddr clientPort} {
     variable opts
     variable uid
     Log "connect from $clientAddr:$clientPort"
     if {$opts(proxyHost) != {}} {
         Log "connected via $opts(proxyHost)"
         set tok [Open $opts(targetUrl)]
         upvar 0 $tok state
         Log "waiting for tls connect"
         Wait $tok
     } else {
         Log "direct connection"
         set tok [namespace current]::[incr uid]
         variable $tok
         upvar 0 $tok state
 
         array set URL [uri::split $opts(targetUrl)]
         if {$URL(port) == {}} { 
             set URL(port) [expr {$URL(scheme) == "https" ? 443 : 80}]
         }
 
         set state(sock) [socket $URL(host) $URL(port)]
         if {$URL(scheme) == "https"} {
             ::tls::import $state(sock)
         }
         fconfigure $state(sock) \
             -buffering $opts(buffering) -translation $opts(translation)
         set state(status) "ssl"
     }
     set state(connectTime) [clock seconds]
     Log "tunnel $tok created"
     if {[info exists state(after)]} {
         after cancel $state(after)
         unset state(after)
     }
     set state(client) $chan
     fconfigure $state(client) \
         -blocking 0 -buffering $opts(buffering) -translation $opts(translation)
     fileevent $chan readable \
         [list [namespace origin Fcopy] $tok $chan $state(sock)]
     fileevent $state(sock) readable \
         [list [namespace origin Fcopy] $tok $state(sock) $chan]
 
     return
 }
 
 proc tlspipe::Fcopy {token source target} {
     upvar 0 $token state
     variable NonPrinting
 
     if {[eof $source]} {
         set msg "eof on $source"
         set status 1
     } else {
         set status [catch {
             set data [read $source]
             puts -nonewline $target $data
             set pdata [string map $NonPrinting $data]
             Log "$source->$target [string length $data] bytes {$pdata}"
         } msg]
     }
 
     if {$status != 0} {
         close $source
         catch {close $target}
         Finish $token $msg
         if {[info exists state(error)]} {
             Log $state(error)
         }
     }
     return
 }
 
 proc tlspipe::Open {url} {
     variable uid
     variable opts
     set tok [namespace current]::[incr uid]
     variable $tok
     upvar 0 $tok state
 
     set state(sock) [socket $opts(proxyHost) $opts(proxyPort)]
     fconfigure $state(sock) -blocking 0 -buffering line -translation crlf
     set state(after) [after 30000 \
                           [list [namespace origin Finish] $tok timeout]]
     set state(url) $url
     set state(status) unconnected
     set state(body) {}
 
     fileevent $state(sock) writable [list [namespace origin Connect] $tok]
     fileevent $state(sock) readable [list [namespace origin Link] $tok]
     return $tok
 }
 
 # At this point we have an open HTTP connection to the proxy server.
 # We now ask it to make a connection for us.
 proc tlspipe::Connect {token} {
     variable $token
     variable opts
     upvar 0 $token state
 
     if {[eof $state(sock)]} {
         Finish $token "error during connect"
     } else {
         set state(status) connect
         fileevent $state(sock) writable {}
 
         array set URL [uri::split $state(url)]
         if {$URL(port) == {}} { 
             set URL(port) [expr {$URL(scheme) == "https" ? 443 : 80}]
         }
 
         puts $state(sock) "CONNECT $URL(host):$URL(port) HTTP/1.1"
         puts $state(sock) "Host: $URL(host)"
         puts $state(sock) "User-Agent: $opts(userAgent)"
         puts $state(sock) "Proxy-Connection: keep-alive"
         puts $state(sock) "Connection: keep-alive"
         if {$opts(proxyUser) != {} && $opts(proxyPass) != {}} {
             set auth "Proxy-Authorization: Basic\
                          [base64::encode $opts(proxyUser):$opts(proxyPass)]"
             puts $state(sock) $auth
         }
         puts $state(sock) ""
     }
     return
 }
 
 proc tlspipe::Finish {token {err {}}} {
     variable opts
     variable $token
     upvar 0 $token state
 
     set state(disconnectTime) [clock seconds]
     Log "shutdown $token  duration:\
          [expr {$state(disconnectTime) - $state(connectTime)}]s"
     catch {close $state(sock)}
     catch {after cancel $state(after)}
     if {$err != {}} {
         set state(error) $err
         set state(status) error
     } else {
         set state(ok)
     }
     return
 }
 
 proc tlspipe::Link {token} {
     variable opts
     variable $token
     upvar 0 $token state
 
     if {[eof $state(sock)]} {
         Finish $token "connection closed"
         return
     }
 
     switch -exact -- $state(status) {
         connect {
             # At this point our proxy has opened up a link to the
             # remote site. Lets read the result.
             # FIX ME: we should check for failure here.
             set block [read $state(sock)]
             set reply [split [lindex [split $block \n] 0] " "]
             Log "CONNECT: << $block >>"
 
             if {![string match "2*" [lindex $reply 1]]} {
                 Log "CONNECT failed."
             }
 
             # Configure the channel for the tunnel comms.
             fconfigure $state(sock) \
                 -buffering $opts(buffering) \
                 -translation $opts(translation)
 
             array set URL [uri::split $state(url)]
             if {$URL(scheme) == "https"} {
                 # Now we upgrade the link to SSL.
                 if {[catch {::tls::import $state(sock)} msg]} {
                     Log "connect error: $msg"
                 }
             }
 
             # Now we are talking through the proxy to the remote site.
             fileevent $state(sock) readable {}
 
             # Signal our SSL connection
             set state(status) ssl
         }
     }
     return
 }
 
 proc tlspipe::Wait {token} {
     variable $token
     upvar 0 $token state
     # watch it: we have to wait on the real name of this variable
     if {[info exists state(status)]} {
         while {$state(status) == "unconnected" \
                    || $state(status) == "connect"} {
             Log "waiting: status currently $state(status)"
             vwait "$token\(status\)"
         }
     }
 }
 # -------------------------------------------------------------------------
 # Description:
 #  Pop the nth element off a list. Used in options processing.
 #
 proc ::tlspipe::Pop {varname {nth 0}} {
     upvar $varname args
     set r [lindex $args $nth]
     set args [lreplace $args $nth $nth]
     return $r
 }
 
 proc ::tlspipe::Main {args} {
     # Create a server socket
     variable opts
 
     # Process the command line arguments
     while {[string match -* [set option [lindex $args 0]]]} {
         switch -exact -- $option {
             -proxy {
                 # eg: -proxy http://wwwcache:8080
                 array set URL [uri::split [Pop args 1]]
                 if {$URL(port) == {}} { set URL(port) 80 }
                 set opts(proxyHost) $URL(host)
                 set opts(proxyPort) $URL(port)
             }
             -target {
                 # eg: -target https://max.tclers.tk:443
                 set opts(targetUrl) [Pop args 1]
 
             }
             -local {
                 # eg: -local 127.0.0.1:8080
                 foreach {if port} [split [Pop args 1] :] {}
                 if {$if != {}} { set opts(serverAddr) $if }
                 if {$port != {}} { set opts(serverPort) $port }
             }
             -buffering {
                 set opts(buffering) [Pop args 1]
             }
             -translation {
                 set opts(translation) [Pop args 1]
             }
             --   { Pop args ; break }
             default {
                 return -code error "invalid option \"$option\":\
                        must be one of -buffering, -proxy, -target or -local"
             }
         }
         Pop args
     }
 
     Log "Config: [array get opts]"
     set server [socket -server [namespace origin Accept] \
                     -myaddr $opts(serverAddr) $opts(serverPort)]
     Log "listening on [fconfigure $server -sockname]"
 
     vwait ::forever
 
     close $server
 }
 
 if {!$::tcl_interactive} {
     eval [list ::tlspipe::Main] $argv
 }
----
See also [tls], [tunnel]

[[ [Category Internet] | [category security] ]]