/jabberlib/https.tcl
TCL | 677 lines | 314 code | 109 blank | 254 comment | 47 complexity | 43686f0fb1f861c7057b2b42a6ca8ef6 MD5 | raw file
Possible License(s): AGPL-3.0
- # 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@nes.ru>
- #
- # This source file is distributed under the BSD license.
- #
- # $Id: https.tcl 1282 2007-10-26 17:40:59Z sergei $
- package require base64
- package require ntlm 1.0
- package require autoconnect 0.2
- package provide autoconnect::https 1.0
- namespace eval https {
- namespace export connect
- variable debug 0
- autoconnect::register https [namespace current]::connect
- }
- # 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]
- array set state $args
- if {[string length $state(-command)]} {
- set state(async) 1
- }
- if {[catch {set state(peer) [fconfigure $sock -peername]}]} {
- catch {close $sock}
- if {$state(async)} {
- after idle [list $state(-command) ERROR network-failure]
- Free $token
- return
- } else {
- Free $token
- return -code error network-failure
- }
- }
- 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 {
- catch {close $sock}
- 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"
- fileevent $state(sock) writable {}
- 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
- set username $state(-username)
- regexp {(\w+)[\\/](.*)} $username -> domain username
- set ntlmtok [NTLM::new -domain $domain \
- -host $host \
- -username $username \
- -password $state(-password)]
- set message1 [$ntlmtok type1Message]
- set state(ntlmtok) $ntlmtok
- 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
- return
- } elseif {$code != 407} {
- # Failure
- Finish $token $state(result)
- return
- }
- 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
- $state(ntlmtok) parseType2Message -message $message2
- set message3 [$state(ntlmtok) type3Message]
- $state(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
- }