###########################################################################
# Copyright (c) 1998, Jeffrey Glen Rennie
# All rights reserved.
###########################################################################

###########################################################################
# header API:

# proc header::GetLineCount ( varHdr )
#   Returns the number of lines in the header, including line zero

# proc header::Serialize { varHdr }
#   Assembles header into socket-ready string, with \n for line delimiters

# the option argument is case insensitive in all the following functions:

# proc header::ExistOption { varHdr option}
#   Returns bool if the option is present in the header. 

# proc header::GetOption { varHdr option}
#   Returns string value of option.  Throws error if option does not exist

# proc header::SetOption { varHdr option value }
#   Set's option's value to value in header.  Preserves order if already
#   present.  Otherwise, appends to header.

# proc header::AppendOption {varHdr option value }
#   Set's option's value to value in header, appending it as last option.
#   If option is already present, moves to bottom of header

# proc header::RemoveOption { varHdr option }
#   Remove's option from header if present.
#   Does not throw exception if option does not exist.

# proc header::ReadRequestHeader { sock callback }
# proc header::ReadResponseHeader { sock callback }
#   Reads in a header from sock.  Calls callback when done.  Callback must
#   have the signature:
#   Callback { sock resultCode hdr }
#     resultCode can be one of the following values:
#       PrematureEof
#       NoHeader      
#       Header
#     If resultCode is NoHeader, then the hdr argument is set directly
#     to the string received in that socket.  It will not be a header
#     structure.

# proc header::GetLineZero { varHdr }
#   Returns a linezero structure representing the first line of the header,
#   which will either be a request line or a status line

# proc header::SetLineZero { varHdr linezero }
#   Sets the first line in an HTTP header to be linezero.
#   linezero must be a structure of type linezero

# struct linezero has the following members:
# if Type == Request
#    Method, Url, ShortUrl, Host, Port, HttpVersion
# else Type == Response
#    HttpVersion, StatusCode, ReasonPhrase




namespace eval header {
}

proc header::TestCallback { sock resultCode thdr } {
    global hdr
    set hdr $thdr
}

# returns 1 if there was enough in the buffer to get a whole line
# returns 0 if there was not enough to get a whole line
proc header::GetLine { sock varLine } {
    upvar $varLine line
    set result 1
    if { [eof $sock] } {
	error "eof $sock"
    } else {
	if { -1 == [gets $sock line] } {
	    set result 0
	}
    }
    set result
}

proc header::ReadLineZero { sock callback parseProc} {
    if [catch {set isFullLine [GetLine $sock line]}] {
	header::Return PrematureEof $sock $callback {} {} {}
    } elseif $isFullLine {
	dbg::puts header $line
	if { [string trim $line] == "" } {
	    # the next line will be line one
	} elseif [ catch { set lz [$parseProc $line]} err] {
	    dbg::puts header $err
	    header::Return NoHeader $sock $callback $line {} {}
	} else {
	    # this is line one
	    fileevent $sock readable [list header::ReadLine $sock $callback \
		    $lz {} {} ]
	}
    }
}

proc header::AppendLine { value option varTable varOrder } {
    upvar $varTable table
    upvar $varOrder order

    set value [string trim $value]
    set option [string trim $option]
    set loOption [string tolower $option]
    # do some extra work just in case we have duplicate options
    if [info exists table($loOption) ] {
	set counter 1
	set loOption "[string tolower $option] $counter"
	while { [info exists table($loOption)] } {
	    incr counter
	    set loOption "[string tolower $option] $counter"
	}
	set option "$option $counter"
    }
    lappend order $option
    set table($loOption) $value
}

proc header::DemangleOptionName { option } {
    regsub { [0-9]+$} $option {} option
    set option
}

proc header::ReadLine { sock callback line0 arrTable order} {
    if [catch {set isFullLine [GetLine $sock line]}] {
	header::Return PrematureEof $sock $callback $line0 $arrTable $order
    } elseif $isFullLine { 
	dbg::puts header $line
	if { [string trim $line] == "" } {
	    header::Return Header $sock $callback $line0 $arrTable $order
	} else {
	    if { ![regexp {([^:]*):(.*)$} $line x option value] } {
		dbg::puts header "Bad line in header on $sock: $line"
	    } else {
		#we have parsed the line now save it's values
		array set table $arrTable
		AppendLine $value $option table order
		fileevent $sock readable [list header::ReadLine \
			$sock $callback $line0 [array get table] $order]
	    }
	}
    }
}

proc header::Make { } {
    list {} {} {}
}
		
proc header::Return { result sock callback line0 arrTable order} {
    if { $result == "PrematureEof" } {
	catch { close $sock }
    } else {
	fileevent $sock readable {}
	fconfigure $sock -translation binary -buffering full
    }
    eval $callback [list $sock $result [list $line0 $arrTable $order]]
}

proc header::ReconstructHeader { line0 arrTable order } {
    set result "[linezero::Serialize line0]\n"
    array set table $arrTable
    foreach option $order {
	set lowerOption [string tolower $option]
	catch { 
	    append result \
		    "[DemangleOptionName $option]: $table($lowerOption)\n"
	}
    }
    set result
}

###########################################################################
# API:

proc header::GetLineCount { varHdr } {
    upvar $varHdr hdr
    expr { [llength [lindex $hdr 1]] / 2 + 1}
}

proc header::Serialize { varHdr } {
    upvar $varHdr hdr
#     if [ExistOption hdr "content-type" ] {
# 	AppendOption hdr "Content-Type" [GetOption hdr "Content-Type"]
#     }
    eval header::ReconstructHeader $hdr
}

proc header::ExistOption { varHdr option} {
    upvar $varHdr hdr
    set arrTable [lindex $hdr 1]
    array set table $arrTable
    set option [string trim [string tolower $option]]
    info exists table($option)
}

proc header::GetOption { varHdr option} {
    upvar $varHdr hdr
    set arrTable [lindex $hdr 1]
    array set table $arrTable
    set option [string trim [string tolower $option]]
    set table($option)
}

proc header::SetOption { varHdr option value } {
    upvar $varHdr hdr
    if { ![ExistOption hdr $option] } {
	header::AppendOption hdr $option $value
    } else {
	set arrTable [lindex $hdr 1]
	array set table $arrTable
	set option [string trim [string tolower $option]]
	set table($option) $value
	set hdr [lreplace $hdr 1 1 [array get table]]
    }	
}    

proc header::AppendOption {varHdr option value } {
    upvar $varHdr hdr
    if [ExistOption hdr $option] {
	set hdr [header::RemoveOption hdr $option]
    } 
    set order [lindex $hdr 2]
    lappend order $option
    set arrTable [lindex $hdr 1]
    array set table $arrTable
    set option [string trim [string tolower $option]]
    set table($option) $value
    set hdr [lreplace $hdr 1 2 [array get table] $order]
}    

proc header::ReadResponseHeader { sock callback } {
    fconfigure $sock -buffering line -translation auto
    fileevent $sock readable [list header::ReadLineZero $sock $callback \
	    linezero::ParseResponseLine]
}

proc header::ReadRequestHeader { sock callback } {
    fconfigure $sock -buffering line -translation auto
    fileevent $sock readable [list header::ReadLineZero $sock $callback \
	    linezero::ParseRequestLine]
}

proc header::RemoveOption { varHdr option } {
    upvar $varHdr hdr
    #first remove from table
    set arrTable [lindex $hdr 1]
    array set table $arrTable
    set option [string trim [string tolower $option]]
    catch { unset table($option) }

    #now remove from order
    set order [lindex $hdr 2]
    set newOrder [list ]
    foreach opt $order {
	if [string compare [string tolower $opt] $option] {
	    lappend newOrder $opt
	}
    }    
    set hdr [lreplace $hdr 1 2 [array get table] $newOrder]
}

proc header::GetTransferEncoding { varHdr } {
    upvar $varHdr hdr
    set result "identity"
    if [ExistOption hdr "Transfer-Encoding"] {
	set result [GetOption hdr "Transfer-Encoding"]
    } elseif [ExistOption hdr "Transfer-Coding"] {
	set result [GetOption hdr "Transfer-Coding"]
    }
    set result
}

proc header::ContainsLengthInfo { varHdr } {
    upvar $varHdr hdr
    expr { [ExistOption hdr Content-Length] || \
	    [GetTransferEncoding hdr] == "chunked" }
} 

proc header::ContainsEntity { varHdr } {
    upvar $varHdr hdr
    set result [expr { [GetTransferEncoding hdr] == "chunked" || \
	[ExistOption hdr Content-Type] } ]
    if { !$result && [ExistOption hdr Content-Length] && \
	    [GetOption hdr Content-Length] > 0 } {
	set result 1
    }
    set result
}

proc header::GetLineZero { varHdr } {
    upvar $varHdr hdr
    lindex $hdr 0
}

proc header::SetLineZero { varHdr line } {
    upvar $varHdr hdr
    set hdr [lreplace $hdr 0 0 $line]
}
    

namespace eval linezero {
    struct::Declare [namespace current]:: \
	    Type {HttpVersion 1.0} Method Url Protocol \
	    Host {Port 80} ShortUrl StatusCode ReasonPhrase
}

proc linezero::Serialize { varLz } {
    upvar $varLz lz
    Serialize[GetType lz] lz
}

proc linezero::SerializeRequest { varLz } {
    upvar $varLz lz
    set result "[GetMethod lz] [GetUrl lz] HTTP/[GetHttpVersion lz]"
}

proc linezero::SerializeResponse { varLz } {
    upvar $varLz lz
    set result "HTTP/[GetHttpVersion lz] [GetStatusCode lz] \
	    [GetReasonPhrase lz]"
}

proc linezero::ParseResponseLine { line } {
    set w " \t"
    if { ![regexp -nocase "^\[$w]*http(/?)(\[^$w]*)\[$w]+(\[0-9]+)(.*)" \
	    $line match q httpVersion statusCode reasonPhrase] } {
	error "Unrecognized response from server: $line"
    }
    # else
    if { $httpVersion == "" } {
	set httpVersion 1.0
    }
    set lz [Make]
    SetType lz Response
    SetHttpVersion lz $httpVersion
    SetStatusCode lz $statusCode
    SetReasonPhrase lz [string trim $reasonPhrase]
    set lz
}

proc linezero::ParseRequestLine { line } {
    set w " \t"
    if {![regexp -nocase "(\[^$w]+)\[$w]+(\[^$w]+)\[$w]+(\[^$w]+)" \
	    $line x request url protocol] } {
	error "Bad request line: $line"
    }
    set url [string trim $url]
    if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url\
	    x proto host y port srvurl]} {
	error "Unsupported URL: $url"
    }
    if { $port == "" } {
	set port 80
    }
    set httpVersion ""
    regexp {[0-9]+.?[0-9]*$} [string trim $protocol] httpVersion
    if { $httpVersion == "" } {
	set httpVersion 1.0
    }
    # Now return all information in struct
    set lz [Make]
    SetType lz Request
    SetMethod lz $request
    SetUrl lz $url
    SetShortUrl lz $srvurl
    SetHost lz $host
    SetPort lz $port
    SetHttpVersion lz $httpVersion
    set lz
}
    



###########################################################################
# Copyright (c) 1998, Jeffrey Glen Rennie
# All rights reserved.
###########################################################################
