###########################################################################
# Copyright (c) 1998, Jeffrey Glen Rennie
# All rights reserved.
###########################################################################
###########################################################################
# chat.tcl -- here's the code that connects to the server, makes the request,
#   copies from sockets.  The meat of the proxy server.

proc LoadFile { filename } {
    set f [open $filename r]
    set contents [read $f]
    close $f
    set contents
}

namespace eval chat {
    set webSmackerHost "configurewebsmacker"
    set configPage [LoadFile "config.htm"]
    set helpPage [LoadFile "help.htm"]
    set instPage [LoadFile "maninst.htm"]
    set gplPage [LoadFile "gpl.htm"]
    set tokenCounter 0
    # ClientHeader -- The HTTP request header received from the client
    # ServerHeader -- the HTTP response header received from the server
    # ProxyHeader -- A modified version of ServerHeader, which we will
    #                send back to the client in place of the ServerHeader
    struct::Declare Chat ClientHeader ServerHeader \
	    Query {IsOldSock 0} ProxyHeader \
	    ServerSock ClientSock Callback ProcPuts ProcGets {IsFiltering 0} \
	    ShouldRelayServerHeader

    set statusCodesWithNoBody [list 304 204 205 302]

    set badDomain {Http/1.0 404 Non-existent domain
Content-Type: text/html

<html>
<head>
<title>Web Smacker: Non-existent domain</title>
</head>
<body bgcolor="#f8f8f0" link="#000078" alink="#ff0022" vlink="#787878">
<h1><center><strong>Web <i><font color="red">Smacker</font></i></strong></center></h1><p>No such domain: %domain%
<p>This most likely happened because you mistyped the name of the web
page.  Or possibly your internet connection has failed, or the server
to which you tried to connect is down.
<p>Copyright 1998 Jeffrey Glen Rennie
</body>
</html>
}
}

proc chat::NewToken { } {
    variable tokenCounter
    set result [namespace current]::[incr tokenCounter]
}

proc chat::Request { hdr sock callback {query {}} {noHeaderFlag {}}} {
    set token [NewToken]
    global $token
    upvar 0 $token state
    global configData

    # store the original header and query
    set state [ChatMake]
    ChatSetCallback state $callback
    ChatSetClientHeader state $hdr
    ChatSetQuery state $query
    ChatSetClientSock state $sock
    ChatSetShouldRelayServerHeader state \
	    [expr { $noHeaderFlag != "-noheader" }]
    if { ![HandleSpecialRequest $token] } {
	# request the server connection
	if $configData(useProxy) {
	    # connect to the proxy server instead
	    set host $configData(proxyHost)
	    set port $configData(proxyPort)
	} else {	    
	    set lz [header::GetLineZero hdr]    
	    set host [linezero::GetHost lz]
	    set port [linezero::GetPort lz]
	}
	repo::GetServerSocket $host $port [list chat::SendHeader $token]
	#return the token
	set token
    }
}

# remove any options the server isn't supposed to see,
# and use the path only url instead of full one
proc chat::CleanRequestHeader { hdr } {
    global configData
    header::RemoveOption hdr Proxy-Connection
    set lz [header::GetLineZero hdr]
    if !$configData(useProxy) {
	linezero::SetUrl lz [linezero::GetShortUrl lz]
    }
    linezero::SetHttpVersion lz 1.1
    header::SetLineZero hdr $lz
    set hdr
}

proc chat::ReturnBadDomain { token } {
    global $token
    upvar 0 $token state
    variable badDomain

    set hdrClient [ChatGetClientHeader state]
    set lz [header::GetLineZero hdrClient]
    set host [linezero::GetHost lz]
    regsub %domain% $badDomain $host badDomainPage
    catch { puts [ChatGetClientSock state] $badDomainPage }
    catch { close [ChatGetClientSock state] }
    unset state
}    

##################################################
# returns 1 if the request was already handled,
# 0 otherwise
proc chat::HandleSpecialRequest { token } {
    global $token
    upvar 0 $token state
    global configData
    variable webSmackerHost

    set result 0
    set hdrClient [ChatGetClientHeader state]
    set lzClient [header::GetLineZero hdrClient]

    if { [linezero::GetHost lzClient] == $webSmackerHost } {
	ReturnLocalPage $token [linezero::GetShortUrl lzClient]
	set result 1
    } elseif { $configData(filter) && [filter::ShouldBlockUrl \
	    "[linezero::GetHost lzClient][linezero::GetShortUrl lzClient]" \
	    $configData(alwaysBlock)] } {
	dbg::puts filter "----blocking \
		[linezero::GetHost lzClient][linezero::GetShortUrl lzClient]"
	Block $token
	set result 1
    }
    set result
}

proc chat::ReturnPage { token page } {
    global $token
    upvar 0 $token state

    set hdrServer [header::Make]
    set hdrServer [header::Make]
    header::SetLineZero hdrServer \
	    [linezero::ParseResponseLine "HTTP/1.1 200 Ok"]
    header::AppendOption hdrServer "Content-Type" "text/html"
    header::AppendOption hdrServer "Content-Length" [string length $page]
    ChatSetServerHeader state $hdrServer
    if [catch { 
	RelayServerHeader $token -notouch
	puts -nonewline [ChatGetClientSock state] $page 
    } err ] {
	dbg::puts chat "Error returning local page: $err"
	Finish $token ClientSocketClosed
    } else {
	Finish $token ServerSocketClosed
    }
}
    
proc chat::ReturnLocalPage { token shortUrl} {
    variable configPage
    variable helpPage
    variable instPage
    variable gplPage

    if [regexp -nocase "help" $shortUrl] {
	ReturnPage $token $helpPage
    } elseif [regexp -nocase "maninst" $shortUrl] {
	ReturnPage $token $instPage
    } elseif [regexp -nocase "gpl" $shortUrl] {
	ReturnPage $token $gplPage
    } else {
	config::DoConfigDialog
	ReturnPage $token $configPage
    }
}
	
proc chat::Block { token } {
    global $token
    upvar 0 $token state

    set hdrServer [header::Make]
    header::SetLineZero hdrServer \
	    [linezero::ParseResponseLine "HTTP/1.1 403 Forbidden"]
    header::AppendOption hdrServer "Content-Length" 0
    ChatSetServerHeader state $hdrServer
    if [catch { RelayServerHeader $token -notouch}] {
	Finish $token ClientSocketClosed
    } else {
	Finish $token ServerSocketClosed
    }
}    

proc chat::SendHeader { token serverSock isOldSock } {
    upvar #0 configData(useProxy) useProxy
    global $token
    upvar 0 $token state

    # check to see if the connection failed
    if { [catch { set feof [eof $serverSock]}] || $feof } {
	ReturnBadDomain $token
	return
    }
    # first record if this is an old, used sock
    ChatSetIsOldSock state $isOldSock
    ChatSetServerSock state $serverSock
    # we have now just connected to serverSock, so send the header
    set hdr [CleanRequestHeader [ChatGetClientHeader state]]
    if [catch { 
	puts $serverSock [header::Serialize hdr]
	flush $serverSock
	fconfigure $serverSock -translation binary
	# send the query if there is one
	set query [ChatGetQuery state]
	if [string length $query] {
	    puts -nonewline $serverSock $query
	    flush $serverSock
	}
	# now wait for the server's header
	header::ReadResponseHeader $serverSock [list chat::Chat $token]
    } err ] {
	catch {close $serverSock}
	if { $isOldSock } {
	    # try again
	    dbg::puts chat "Error $err while using old $serverSock, \
		    retrying. . ."
	    after idle [list chat::Request [ChatGetClientHeader state] \
		    [ChatGetClientSock state] [ChatGetCallback state] \
		    [ChatGetQuery state]]
	} else {
	    dbg::puts chat "ERROR: unexpected $err on $serverSock."
	}
    }
}

proc chat::Chat { token serverSock resultCode hdr } {
    global $token
    upvar 0 $token state

    if { $resultCode == "PrematureEof" } {
	dbg::puts chat "Premature eof on $serverSock while trying \
		to read response header."
	set retry [ChatGetIsOldSock state]
    } elseif { $resultCode == "NoHeader" } {
	dbg::puts chat "Response from $serverSock contains no header."
	set retry [ChatGetIsOldSock state]
    } else {
	ChatSetServerHeader state $hdr
	if [catch {RelayServerHeader $token} ] {
	    Finish $token "ClientSocketClosed"
	} elseif [catch {ChooseCopyProc $token}] {
	    set retry [ChatGetIsOldSock state]
	}
    }
    
    if [info exists retry] {
	catch { close $serverSock }
	if $retry {	    
	    dbg::puts chat "Retrying. . ."
	    after idle [list chat::Request [ChatGetClientHeader state] \
		    [ChatGetClientSock state] [ChatGetCallback state] \
		    [ChatGetQuery state]]
	} else {
	    # at least try to send the header before we close
	    ChatSetServerHeader state $hdr
	    catch { RelayServerHeader $token -notouch }
	    Finish $token "ServerSocketClosed"
	}
    }
}

proc chat::DetermineProcPuts { token } {
    global $token
    upvar 0 $token state

    set hdrClient [ChatGetClientHeader state]
    set lzClient [header::GetLineZero hdrClient]
    set hdrServer [ChatGetServerHeader state]
    set lzServer [header::GetLineZero hdrServer]
    set procPuts PutPacket
    if { [linezero::GetHttpVersion lzClient] >= 1.1 && \
	[linezero::GetHttpVersion lzServer] >= 1.1 } {
	if { [header::GetTransferEncoding hdrServer] == "chunked" || \
		[ChatGetIsFiltering state] } {
	    set procPuts PutChunk
	}
    }
    set procPuts
}

########################################################################
# RelayServerHeader token [-notouch]
#   if -notouch specified, then it won't modify the header at all
proc chat::RelayServerHeader { token {option {}} } {
    set touch [expr { $option != "-notouch" }]
    global $token
    upvar 0 $token state
    # send the header to the client
    set hdrClient [ChatGetClientHeader state]
    set lzClient [header::GetLineZero hdrClient]
    set hdrServer [ChatGetServerHeader state]
    set lzServer [header::GetLineZero hdrServer]

    if ![ChatGetShouldRelayServerHeader state] {
	set dontSendHeader 1
    }
    ChatSetIsFiltering state [DecideToFilter $token $hdrServer]
    # if the client is http 1.0, and the server responds with chunks, 
    # we need to take out the Transfer-Encoding line
    # also, http 1.0 clients won't expect a 100 message
    if { [linezero::GetHttpVersion lzClient] < 1.1 } {
	if $touch {
	    header::RemoveOption hdrServer Transfer-Encoding
	    header::RemoveOption hdrServer Transfer-Coding
	}
	if { [linezero::GetStatusCode lzServer] == 100 } {
	    set dontSendHeader 1
	}
    }
    # we also have to modify the length info if we are filtering
    if { [ChatGetIsFiltering state] && $touch } {
	header::RemoveOption hdrServer Content-Length
    }
    if { [DetermineProcPuts $token] == "PutChunk" && $touch } {
	header::SetOption hdrServer Transfer-Encoding chunked
    }
    # if the http 1.1 server requests connection: close
    # that's fine, but we don't have to close the connection to
    # the client, so remove that option
    if $touch {
	header::RemoveOption hdrServer "connection"
    }
    # now save our changes
    ChatSetProxyHeader state $hdrServer
    if ![info exists dontSendHeader] {
	# now send this chingadera!
	puts [ChatGetClientSock state] [header::Serialize hdrServer]
	flush [ChatGetClientSock state]
    }
}

proc chat::ReceiveSizedPacket { token serverSock procPuts size } {
    if { [eof $serverSock] || \
	    [catch {set packet [read $serverSock $size]}] } {
	Finish $token ServerSocketClosed
    } else {
	eval $procPuts [list $packet]
	incr size -[string length $packet]
	if { $size <= 0 } {
	    Finish $token ReceivedWholeLength
	} else {
	    if [catch {
		# next time call with decremented size
		fileevent $serverSock readable [list chat::ReceiveSizedPacket \
			$token $serverSock $procPuts $size]
	    } ] {
		Finish $token ClientSocketClosed
	    }
	}
    }
}

proc chat::ReceivePacket { token serverSock procPuts } {
    if { [eof $serverSock] || \
	    [catch {set packet [read $serverSock]}] } {
	Finish $token ServerSocketClosed
    } else {
	eval $procPuts [list $packet]
    }
}
	
proc chat::ReceiveChunkSize { token serverSock procPuts } {
    if { [eof $serverSock] || \
	    [catch {gets $serverSock line} err] } {
	catch { dbg::puts chat "Error in ReceiveChunkSize: $err" }
	Finish $token ServerSocketClosed
    } else {
	if { [string trim $line] == "" } {
	    # this is the crlf at the end of the chunk, so just wait for the
	    # next chunksize
	} elseif { [scan $line "%x" size] != -1 && $size == 0 } {
	    # this is the end of the body.  Get the last crlf, and then finish
	    catch {gets $serverSock crlf}
	    Finish $token ReceivedAllChunks
	} else {
	    if [catch {
		fileevent $serverSock readable [list \
			chat::ReceiveChunkBody $token $serverSock $procPuts \
			$size {} ]
	    } ] {
		Finish $token ClientSocketClosed
	    }
	}
    }
}
    
proc chat::ReceiveChunkBody { token serverSock procPuts chunkSize chunkBody } {
    if { [eof $serverSock] || \
	    [catch {set packet [read $serverSock $chunkSize]} err] } {
	catch { dbg::puts chat "Error in ReceiveChunkBody: $err" }
	Finish $token ServerSocketClosed
    } else {
	incr chunkSize -[string length $packet]
	append chunkBody $packet
	if [catch {
	    if { $chunkSize <= 0 } {
		# we received the whole chunk
		eval $procPuts [list $chunkBody]
		fileevent $serverSock readable [list \
			chat::ReceiveChunkSize $token $serverSock $procPuts]
	    } else {
		# there's still more chunk left
		eval $procPuts [list $chunkBody]
		# regsub -all \{ $chunkBody \\\{ chunkBody
		# regsub -all \} $chunkBody \\\} chunkBody
		fileevent $serverSock readable [list \
			chat::ReceiveChunkBody $token $serverSock $procPuts \
			$chunkSize {} ]
	    }
	} ] {
	    Finish $token ClientSocketClosed
	}
    }
}

proc chat::PutChunk { token clientSocket isFiltering chunkBody } {
    if $isFiltering {
	if [catch { filter::Filter $token chunkBody } err ] {
	    dbg::puts chat "chat error while filtering: $err"
	}
    }
    set chunkSize [string length $chunkBody]
    if { $chunkSize > 0 } {
	# dbg::puts content $chunkBody
	if [catch {
	    puts -nonewline $clientSocket [format "%x\r\n" $chunkSize]
	    puts -nonewline $clientSocket "$chunkBody\r\n"
	} err] {
	    Finish $token ClientSocketClosed
	}
    }
}
	    
proc chat::PutPacket { token clientSocket isFiltering packet } {
    if $isFiltering {
	if [catch { filter::Filter $token packet } err] {
	    dbg::puts chat "chat error while filtering: $err"
	}
    }
    set size [string length $packet]
    if { $size > 0 } {
	# dbg::puts content $packet
	if [catch {
	    puts -nonewline $clientSocket $packet
	} err] {
	    Finish $token ClientSocketClosed
	}
    }
}

proc chat::DecideToFilter { token hdrServer } {
    global configData
    global $token
    upvar 0 $token state

    set result 0
    if { $configData(filter) } {
	set result [expr { \
		![header::ExistOption hdrServer "Content-Type"] || \
		[regexp -nocase {html} \
		[header::GetOption hdrServer "Content-Type"]] }]
	if { $result } {
	    set hdrClient [ChatGetClientHeader state]
	    set lzClient [header::GetLineZero hdrClient]
	    filter::Initialize $token \
		    "[linezero::GetHost lzClient][linezero::GetShortUrl lzClient]" \
		    $configData(filterMode)
	}
    }
    set result
}

# now we successfully have the client header and the server header
# so analyze them and then copy the body appropriately
proc chat::ChooseCopyProc { token } {
    global $token
    upvar 0 $token state
    variable statusCodesWithNoBody

    set hdrClient [ChatGetClientHeader state]
    set lzClient [header::GetLineZero hdrClient]
    set hdrServer [ChatGetServerHeader state]
    set lzServer [header::GetLineZero hdrServer]
    set sockServer [ChatGetServerSock state]
    set sockClient [ChatGetClientSock state]
    set statusCode [linezero::GetStatusCode lzServer]
    if { $statusCode == 100 } {
	# first, special case of 100 means continue, and we'll see another
	# header
	fconfigure $sockClient -translation {auto crlf}
	header::ReadResponseHeader \
		[ChatGetServerSock state] [list chat::Chat $token]
    } elseif { [header::ExistOption hdrServer Content-Length] && \
	    [header::GetOption hdrServer Content-Length] == 0 } {
	# handle special case where content-length == 0
	Finish $token NoBody
    } elseif { [lsearch $statusCodesWithNoBody $statusCode] > -1 && \
	    ![header::ContainsEntity hdrServer] } {
	# it's a statuscode that doesn't have a body.
	Finish $token NoBody
    } else {
	# select the put proc
	set procPuts [list [DetermineProcPuts $token] $token $sockClient \
		[ChatGetIsFiltering state]]
	dbg::puts chat "procPuts: $procPuts"
	ChatSetProcPuts state $procPuts
	# select the read proc
	if { [header::GetTransferEncoding hdrServer] == "chunked" } {
	    set procGets [list chat::ReceiveChunkSize $token \
		    $sockServer $procPuts]
	} elseif { [header::ExistOption hdrServer Content-Length] } {
	    set procGets [list chat::ReceiveSizedPacket $token $sockServer \
		    $procPuts [header::GetOption hdrServer Content-Length]]
	} else {
	    set procGets [list chat::ReceivePacket $token $sockServer \
		    $procPuts]
	}
	dbg::puts chat "procGets: $procGets"
	ChatSetProcGets state $procGets
	#prepare the sockets
	fconfigure $sockClient -translation binary
	fconfigure $sockServer -translation binary
	fileevent $sockServer readable $procGets
    }
}
	
###########################################################################
# reason can have one of the following values:
#    ServerSocketClosed, ReceivedWholeLength, ReceivedAllChunks, 
#    ClientSocketClosed, NoBody, Abort

proc chat::Finish { token reason } {
    global $token
    upvar 0 $token state

    dbg::puts chat "Finish $token $reason" 
    # this transaction may have already been aborted
    if { ![info exists state] } {
	return
    }

    # if the client socket closed, then everythings screwed up. . .abort
    if { $reason == "ClientSocketClosed" } {
	Abort $token 
	return
    }

    if [ChatGetIsFiltering state] {
	# we want to turn filtering off there so we need to modify the 
	# puts command
	catch {
	    set cmd [lrange [ChatGetProcPuts state] 0 2]
	    eval $cmd [list 0 [filter::Finish $token]] 
	}
	filter::Clean $token
    }

    set hdrClient [ChatGetClientHeader state]
    set lzClient [header::GetLineZero hdrClient]
    set hdrServer [ChatGetServerHeader state]
    set lzServer [header::GetLineZero hdrServer]
    set hdrProxy [ChatGetProxyHeader state]
    set sockServer [ChatGetServerSock state]
    set sockClient [ChatGetClientSock state]
    set wasSockServerClosed 0
    set wasSockClientClosed 0

    # first, if the client is receiving chunks, send him the zero length
    # chunk to signal end of file
    if { [lindex [ChatGetProcPuts state] 0] == "PutChunk" } {
	catch { puts -nonewline [ChatGetClientSock state] "0\r\n\r\n" }
    }
    catch { flush $sockClient }
    # close the client if it is http 1.0 or if there was no length information
    # in the server header
    if { [linezero::GetHttpVersion lzClient] <= 1.0 } {
	catch { close $sockClient }
	set wasSockClientClosed 1
    }
    if { [linezero::GetHttpVersion lzServer] <= 1.0 } {
	catch { close $sockClient }
	catch { close $sockServer }
	set wasSockServerClosed 1
	set wasSockClientClosed 1
    }   
    if { ![header::ContainsLengthInfo hdrProxy] && \
	    $reason != "NoBody" } {
	catch { close $sockClient }
	set wasSockClientClosed 1
    }
    if { ![header::ContainsLengthInfo hdrServer] && \
	    $reason != "NoBody" } {
	catch { close $sockServer }
	set wasSockServerClosed 1
    }
    if { $reason == "ServerSocketClosed" } {
	catch { close $sockServer }
	set wasSockServerClosed 1
    }
    if { [header::ExistOption hdrServer "connection"] && \
	    [string tolower [header::GetOption hdrServer "connection"]] == \
	    "close"} {
	catch { close $sockServer }
	set wasSockServerClosed 1
    }
    
    if !$wasSockServerClosed {
	repo::DoneWithServerSocket $sockServer \
		[linezero::GetHost lzClient] [linezero::GetPort lzClient]
    }

    #clean up memory
    set callback [ChatGetCallback state]
    unset state
    eval $callback $sockClient $wasSockClientClosed
}

proc chat::Abort { token } {
    global $token
    upvar 0 $token state

    catch {
	if [ChatGetIsFiltering state] {
	    filter::Clean $token
	}
    }
    set callback [ChatGetCallback state]
    set sockServer [ChatGetServerSock state]
    set sockClient [ChatGetClientSock state]
    catch { close $sockServer }
    catch { close $sockClient }
    eval $callback $sockClient 1
    unset state
}
###########################################################################
# Copyright (c) 1998, Jeffrey Glen Rennie
# All rights reserved.
###########################################################################
