# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package minihttpd 1.1
# Meta as::author      {Emmanuel Frecon}
# Meta as::build::date 2015-03-24
# Meta as::license     BSD
# Meta as::origin      http://sourceforge.net/projects/til
# Meta description     This module provides a functional but minimal HTTPd
# Meta platform        tcl
# Meta require         {Tcl 8.2}
# Meta require         diskutil
# Meta require         html
# Meta require         http
# Meta require         logger
# Meta require         mimetype
# Meta require         textutil
# Meta require         uri
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.2
package require diskutil
package require html
package require http
package require logger
package require mimetype
package require textutil
package require uri

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide minihttpd 1.1

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# httpd.tcl --
#
#	This modules provides a functional but minimal HTTPd
#
# Copyright (c) 2004-2005 by the Swedish Institute of Computer Science.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.


package require Tcl 8.2
package require logger
package require uri
package require mimetype
package require html
package require textutil
package require diskutil
package require http

package provide minihttpd 1.1

namespace eval ::minihttpd {
    # Initialise the global state
    variable HTTPD
    if {![::info exists HTTPD]} {
	array set HTTPD {
	    loglevel         "warn"
	    default_port     8080
	    maxportallocs    20
	    servers          ""
	    dateformat       "\[%d%m%y %H:%M:%S\]"
	    validate_timeout 250
	    -default         "index.htm index.html"
	    -dirlist         "*"
	    -logfile         ""
	    -bufsize         32768
	    -sockblock       0
	    -selfvalidate    hostname
	}
	variable log [::logger::init [string trimleft [namespace current] ::]]
	${log}::setlevel $HTTPD(loglevel)
    }
    variable HTTPD_errors
    if {![::info exists HTTPD_errors]} {
	array set HTTPD_errors {
	    204 {No Content}
	    400 {Bad Request}
	    404 {Not Found}
	    503 {Service Unavailable}
	    504 {Service Temporarily Unavailable}
	}
    }

    namespace export loglevel new close config defaults
}


# ::minihttpd::loglevel -- Set/Get current log level.
#
#	Set and/or get the current log level for this library.
#
# Arguments:
#	loglvl	New loglevel
#
# Results:
#	Return the current log level
#
# Side Effects:
#	None.
proc ::minihttpd::loglevel { { loglvl "" } } {
    variable HTTPD
    variable log

    if { $loglvl != "" } {
	if { [catch "${log}::setlevel $loglvl"] == 0 } {
	    set HTTPD(loglevel) $loglvl
	}
    }

    return $HTTPD(loglevel)
}


# ::minihttpd::new -- Start HTTP serving on a port
#
#	This command will start a HTTP server on the port passed as an
#	arguments and serving files under a given root directory.
#	Connection arguments are inherited from the defaults
#	parameters and can be overriden through the additional
#	arrguments or the ::minihttpd::config call.  These are the
#	following options: -default (default file names for
#	directories) -logfile (logfile to output transactions to)
#	-bufsize (buffering size) -sockblock (blocking sockets or not)
#	-dirlist (list of patterns for which directory listing is
#	allowed when the default file does not exist (expressed in
#	server file space)).
#
# Arguments:
#	root	Root directory being served.
#	port	Port on which we listen, negative to start picking at default
#               and looking for any available port.
#	args	Additional list of options and values, as described above.
#
# Results:
#	Return the port on which we listen for connections and serve
#	for HTTP, a negative number otherwise
#
# Side Effects:
#	Will give access to the files on the disk!
proc ::minihttpd::new {root port args} {
    variable HTTPD
    variable log

    # If the port passed as an argument is the one of our servers,
    # reconfigure it and return.
    if { $port > 0 } {
	set idx [lsearch $HTTPD(servers) $port]
	if { $idx >= 0 } {
	    eval config $port $args
	    return $port
	}
    }

    # Serve only if we can access the directory.
    if { ![file isdirectory $root] || ![file readable $root] } {
	${log}::warn "Cannot serve $root, cannot access directory!"
	return -1
    }


    # Positive port will force serving there, check once and return if
    # we start listening on that port (there could be some other
    # process serving that port already).
    if { $port > 0 } {
	if { [catch {socket -server [list ::minihttpd::__accept $port] $port} \
		  sock] } {
	    ${log}::warn "Cannot serve on $port: $sock"
	    return -1
	}
    } else {
	# A negative port was passed, that means we should choose a
	# suitable port.  Start from the default port and increase by
	# 2 until we find an available port.  This could be an
	# infinite loop by WTH!
	set sock ""
	set port $HTTPD(default_port)
	set attempts 0
	while { $sock == "" } {
	    if { [catch {socket -server [list ::minihttpd::__accept \
					     $port] $port} \
		      sock] } {
		set sock ""
		${log}::notice "Cannot serve on $port: $sock"
		incr port 2
		incr attempts
		if { $attempts >= $HTTPD(maxportallocs) } {
		    ${log}::warn "Attempted $HTTPD(maxportallocs) port\
                                  allocations without any success, giving up!"
		    return -1
		}
	    }
	}
    }

    set varname "::minihttpd::Server_${port}"
    upvar \#0 $varname Server

    set Server(port) $port
    set Server(root) [::diskutil::absolute_path $root]
    set Server(hostname) ""
    set Server(ip) ""
    set Server(clients) ""
    set Server(listen) $sock
    set Server(selfvalidation_urls) ""
    foreach opt [array names HTTPD "-*"] {
	set Server($opt) $HTTPD($opt)
    }
    lappend HTTPD(servers) $port
    eval config $port $args

    __log $port "Starting HTTP server on port \#$port, root: $Server(root)"

    # Self validate the server, i.e. do a request for / on
    # ourselves so that we trigger the hostname discovery
    # mechanism.  If we do not do this, we will have to wait until
    # the first request before ::minihttpd::fullurl returns a good
    # value.
    if { $Server(-selfvalidate) != "" } {
	set Server(selfvalidation_urls) \
		[list [fullurl $port] "http://localhost:$port/"]
	__selfvalidation $port
    }

    return $port
}


# ::minihttpd::__selfvalidation -- Initiate one validation step
#
#	This command will initiate self validation of the host name of
#	the server through trying to fetch one of the (remaining) self
#	validation URLs.  It also finishes up the validation process
#	through defaulting back to some (hopefully) decent IP address
#	in the end.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#
# Results:
#	None.
#
# Side Effects:
#	Will log on disk if required
proc ::minihttpd::__selfvalidation { port } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server
	
	if { [llength $Server(selfvalidation_urls)] == 0 } {
	    # No more validation URLs found, default to the IP address
	    # if we have a junk hostname and a decent IP address.
	    if { $Server(ip) != "" && $Server(ip) != "127.0.0.1" \
		    && ( $Server(hostname) == "" \
		    || $Server(hostname) == "localhost" )} {
		__log $port "Last resort: defaulting to IP address"
		set Server(hostname) $Server(ip)
	    }
	    __log $port "Server's root is: [fullurl $port]"
	} else {
	    # Pick up the next valid validation URL and try to get it
	    # (from ourselves!).
	    foreach topurl $Server(selfvalidation_urls) {
		__log $port "Self validating through fetching $topurl"
		if { [catch {::http::geturl $topurl -validate 1 \
			-command \
			[list ::minihttpd::__validateroot $port]} err] } {
		    __log $port "Error on validation: $err"
		} else {
		    break
		}
	    }
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}


# ::minihttpd::__verifyhostname -- Verify the host name
#
#	This command is called as a result of the validation check
#	once a host name has been discovered.  It attempts to get the
#	root of this web server through that very host name.  If that
#	fails, the next validation URL will be tried.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	token	Token as returned by ::http::geturl
#
# Results:
#	Return 1 if server's true host name was discovered, 0 otherwise
#
# Side Effects:
#	None.
proc ::minihttpd::__verifyhostname { port token } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	if { [::http::status $token] != "ok" } {
	    set Server(hostname) ""
	    __selfvalidation $port
	} elseif { [::http::status $token] == "ok" } {
	    if { $Server(hostname) == "localhost" \
		    || $Server(hostname) == "" } {
		__selfvalidation $port
	    } else {
		__log $port "Server's root is: [fullurl $port]"
	    }
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
    ::http::cleanup $token
}


# ::minihttpd::__validateroot -- Validate the root
#
#	This command is called as a result of the initial fetch of the
#	root of the web server.  It prints an error message if we did
#	not manage to initialise the hostname correctly.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	token	Token as returned by ::http::geturl
#
# Results:
#	Return 1 if server's true host name was discovered, 0 otherwise
#
# Side Effects:
#	None.
proc ::minihttpd::__validateroot { port token } {
    variable HTTPD
    variable log

    set result 0
    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	upvar \#0 $token htstate
	set Server(selfvalidation_urls) \
		[lrange $Server(selfvalidation_urls) 1 end]
	
	# Force host name to IP address if self-validation tells us so.
	if { $Server(ip) != "" \
		 && [string equal -nocase $Server(-selfvalidate)  "ip"] } {
	    set Server(hostname) $Server(ip)
	}

	if { $Server(hostname) != "" } {
	    ${log}::debug \
		    "Server host name discovered: $Server(hostname), trying it"
	    if { [catch {::http::geturl [fullurl $port] \
		    -timeout $HTTPD(validate_timeout) \
		    -validate 1 \
		    -command \
		    [list ::minihttpd::__verifyhostname $port]} err] } {
		__log $port "Error on hostname verification: $err"
	    }
	    set result 1
	} else {
	    ${log}::warn "Self-validation of host name through\
		          $htstate(url) did not succeed."
	    __selfvalidation $port
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }

    ::http::cleanup $token

    return $result
}


# ::minihttpd::close -- Stop HTTP serving on a port
#
#	This command will stop an existing HTTP server on the port
#	passed as an arguments.  All current connections are
#	immediately closed.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#
# Results:
#	None.
#
# Side Effects:
#	Will log on disk if required
proc ::minihttpd::close { port } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	catch {::close $Server(listen)}
	foreach sock $Server(clients) {
	    ::minihttpd::__disconnect $port $sock
	}
	__log $port "Stopped web server on $port"
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}


# ::minihttpd::__disconnect -- Close a socket
#
#	Close a socket that had been open as a result of a client
#	connection and cleanup all data associated to the client and
#	the socket.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	sock	Socket to client.
#
# Results:
#	None.
#
# Side Effects:
#	Will immediately close the connection to the client, all data lost.
proc ::minihttpd::__disconnect { port sock } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	set idx [lsearch $Server(clients) $sock]
	if { $idx >= 0 } {
	    set varname "::minihttpd::Client_${port}_${sock}"
	    upvar \#0 $varname Client

	    fileevent $sock readable ""
	    catch "flush $sock"
	    unset Client
	    ::close $sock
	    set idx [lsearch -exact $Server(clients) $sock]
	    if { $idx >= 0 } {
		set Server(clients) [lreplace $Server(clients) $idx $idx]
	    }
	} else {
	    ${log}::warn "$sock is not a recognised client of $port"
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}


# ::minihttpd::__accept -- Accept client connections
#
#	Accept connections from clients and arrange for get lines to
#	be read and treated.
#
# Arguments:
#	s_port	Port number of one of our HTTP servers.
#	sock	Socket to client.
#	ipaddr	IP Address of client
#	port	Port number to client
#
# Results:
#	None.
#
# Side Effects:
#	None
proc ::minihttpd::__accept { s_port sock ipaddr port} {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $s_port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${s_port}"
	upvar \#0 $varname Server
	
	set varname "::minihttpd::Client_${s_port}_${sock}"
	upvar \#0 $varname Client

	fconfigure $sock -blocking $Server(-sockblock) \
	    -buffersize $Server(-bufsize) \
	    -translation {auto crlf}
	set Client(sock) $sock
	set Client(ipaddr) $ipaddr
	__translog $Server(port) $sock Connect $ipaddr $port
	lappend Server(clients) $sock
	__hostname $s_port $sock
	fileevent $sock readable [list ::minihttpd::__pull $s_port $sock]
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}


# ::minihttpd::__hostname -- Set/query name of host for server
#
#	Sets or simply queries the name of the host on which the
#	server currently runs.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	sock	Socket to one existing client.
#
# Results:
#	None.
#
# Side Effects:
#	The name will be cached for further use
proc ::minihttpd::__hostname { port { sock "" } } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	# We have a name in the cache, return it
	if { $Server(hostname) != "" } {
	    return $Server(hostname)
	}
	
	# No name, check that the socket is one of ours.
	set idx [lsearch $Server(clients) $sock]
	if { $idx < 0 } {
	    set sock ""
	}

	# No socket, look we we don't have a connected client, we can
	# get information from there.
	if { $sock == "" && [llength $Server(clients)] > 0 } {
	    set sock [lindex $Server(clients) 0]
	}

	# Now, maybe we have a socket to extract information for.  If
	# we do cache the result in Server(hostname).
	if { $sock != "" } {
	    set sockinfo [fconfigure $sock -sockname]
	    set Server(hostname) [lindex $sockinfo 1]
	    if { $Server(ip) == "" || $Server(ip) == "127.0.0.1" } {
		set Server(ip) [lindex $sockinfo 0]
	    }
	}

	if { $Server(hostname) == "" } {
	    # Still in the void, return something wrong but that will
	    # be decent in most cases.
	    if { [info commands ::dnsresolv::hostname] != "" } {
		return [::dnsresolv::hostname]
	    } else {
		return [info hostname]
	    }
	} else {
	    return $Server(hostname)
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }

    return ""
}


# ::minihttpd::__pull -- Pull data from client
#
#	Read, understand and treat requests coming from clients.
#	Arrange for answers to be sent back.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	sock	Socket to client.
#
# Results:
#	None.
#
# Side Effects:
#	None
proc ::minihttpd::__pull { port sock } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server
	
	set idx [lsearch $Server(clients) $sock]
	if { $idx >= 0 } {
	    set varname "::minihttpd::Client_${port}_${sock}"
	    upvar \#0 $varname Client

	    if { [catch {gets $sock line} readCount] != 0 } {
		__translog $port $sock "Error" \
		    "Unable to read request line: $readCount"
		__disconnect $port $sock
	    } else {
		if {![info exists Client(state)]} {
		    if { [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/(1.0|1.1)} \
			      $line x Client(proto) Client(url) Client(query)] } {
			set Client(state) mime
			__translog $port $sock Query $line
		    } else {
			__push_error $port $sock 400 "bad first line: $line"
			return
		    }
		}
		
		set state \
		    [string compare $readCount 0],$Client(state),$Client(proto)
		switch -- $state {
		    0,mime,GET  -
		    0,mime,HEAD -
		    0,query,POST  { __push $port $sock }
		    0,mime,POST   { set Client(state) query }
		    1,mime,POST   -
		    1,mime,HEAD   -
		    1,mime,GET    {
			if [regexp {([^:]+):[   ]*(.*)} \
				$line dummy key value] {
			    set Client(mime,[string tolower $key]) $value
			}
		    }
		    1,query,POST  {
			set Client(query) $line
			__push $port $sock
		    }
		    default {
			if { [eof $sock] } {
			    __translog $port $sock Error \
				"unexpected eof on <$Client(url)> request"
			} else {
			    __translog $port $sock Error \
				"unhandled state <$state> fetching <$Client(url)>"
			}
			__push_error $port $sock 404 ""
		    }
		}
	    }
	} else {
	    ${log}::warn "$sock is not a recognised client of $port"
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
    
}


# ::minihttpd::__dirlist_outfname -- Output one line of directory listing
#
#	This command formats one line for use by the directory
#	listing.  It is internal to the dirlisting algorithm but put
#	outside to simplify it visually.
#
# Arguments:
#	data_p	Pointer to variable to append line representation to
#	fname	Full path to name to add to line
#	date	Pretty printed date of file
#	size	Pretty printed size of file
#	maxnamesize	Maximum size of all names in directory
#	is_hdr	Is this the table header?
#
# Results:
#	None.
#
# Side Effects:
#	Modifies the variable pointed at by data_p
proc ::minihttpd::__dirlist_outfname { data_p fname date size maxnamesize { is_hdr 0 } } {
    upvar $data_p data

    # Name of file, if this is a real file and not the header of the
    # table, see to have a link to it.
    if { ! $is_hdr } {
	set outname [file tail $fname]
	if { [file isdirectory $fname] } {
	    append outname "/"
	}
	append data \
	    "[::html::openTag a href=\"[__StringToURL $outname]\"]"
	
    } else {
	set outname $fname
    }
    append data $outname
    if { ! $is_hdr } {
	append data "[::html::closeTag]"
    }
    
    append data \
	[string repeat " " \
	     [expr $maxnamesize - [string length $outname] + 2]]
    append data \
	[::textutil::adjust $date \
	     -full on -justify left -length 19 -strictlength on]
    append data \
	[::textutil::adjust $size \
	     -full on -justify right -length 10 -strictlength on]
    append data "\n"
}


# ::minihttpd::__dirlisting -- Create directory listing
#
#	This command prepares into the Client global array
#	representing clients the listing of a directory.  The output
#	is in HTML and is roughly similar to the one provided by
#	Apache, except that ordering is not supported.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	sock	Socket to client.
#	dir	Directory to provide an HTML representation for
#	srvdir	Equivalent of that directory, relative to the server.
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::minihttpd::__dirlisting { port sock dir srvdir } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server
	
	set idx [lsearch $Server(clients) $sock]
	if { $idx >= 0 } {
	    set varname "::minihttpd::Client_${port}_${sock}"
	    upvar \#0 $varname Client

	    set flist [glob -nocomplain -- [file join $dir "*"]]
	    set maxsize [string length "Name"]
	    foreach fname $flist {
		set shortname [file tail $fname]
		if { [expr [string length $shortname] + 2] > $maxsize } {
		    set maxsize [expr [string length $shortname] + 2]
		}
	    }

	    set Client(interndata) ""
	    ::html::init
	    ::html::title "Index of $srvdir"
	    append Client(interndata) \
		"[::html::head [list Index of $srvdir]]\n"
	    append Client(interndata) "[::html::bodyTag]\n"
	    
	    append Client(interndata) "[::html::h1 [list Index of $srvdir]]\n"
	    append Client(interndata) "[::html::openTag pre]\n"

	    # Table header
	    __dirlist_outfname Client(interndata) \
		"Name" "Date" "Size   " $maxsize 1
	    append Client(interndata) "<hr />"

	    # File listing.
	    if { $srvdir != "/" } {
		__dirlist_outfname Client(interndata) ".." \
		    [clock format [file mtime [file join $dir ".."]] \
			 -format "%d-%b-%Y %H:%M"] "-   " $maxsize
	    }
	    foreach fname $flist {
		if { [file isdirectory $fname] } {
		    set sz "-   "
		} else {
		    set sz [__friendly_datasize [file size $fname]] 
		}
		__dirlist_outfname Client(interndata) $fname \
		    [clock format [file mtime $fname] \
			 -format "%d-%b-%Y %H:%M"] \
		    $sz $maxsize
	    }
	    append Client(interndata) "<hr />"
	    append Client(interndata) "[::html::closeTag]\n"

	    append Client(interndata) "[::html::closeTag]\n"
	    append Client(interndata) [::html::end]
	} else {
	    ${log}::warn "$sock is not a recognised client of $port"
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}


# ::minihttpd::fullurl -- Computes full URL to local file
#
#	Return the fully qualified URL for a file relative to the root
#	if possible.  All forbidden cases will lead to empty strings.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	fpath	File path (relative to root)
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::minihttpd::fullurl { port { fpath "/" } { fullpath_p "" } } {
    variable HTTPD
    variable log

    if { $fullpath_p != "" } {
	upvar $fullpath_p fullpath
    }

    set fullpath ""
    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	if { [string index $fpath 0] != "/" } {
	    set fpath "/$fpath"
	}

	set mypath [::diskutil::absolute_path \
			[__URLtoString "$Server(root)$fpath"]]
	if { [string first $Server(root) $mypath] != 0 } {
	    # Outside of root directory is an ERROR!
	    set mypath ""
	} else {
	    if {[file isdirectory $mypath]} {
		set defaulted 0
		foreach d $Server(-default) {
		    set fname [file join $mypath $d]
		    if { [file exists $fname] && [file readable $fname] } {
			set mypath $fname
			set defaulted 1
			break
		    }
		}
		if { ! $defaulted } {
		    set match 0
		    foreach ptn $Server(-dirlist) {
			if { [string match $ptn $fpath] } {
			    set match 1
			}
		    }
		    if { ! $match } {
			# Generate an error, directory not allowed
			set mypath ""
		    }
		}
	    }
	}

	if { $mypath != "" } {
	    set fullpath $mypath
	    set url "http://"
	    append url [__hostname $port]
	    append url ":"
	    append url $port
	    set urlpath \
		[string range $mypath [string length $Server(root)] end]
	    if { $urlpath == "" } { set urlpath "/" }
	    append url $urlpath

	    return $url
	} else {
	    return ""
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }

    return ""
}


# ::minihttpd::__push -- Push answer back to client.
#
#	Arrange for answer to be sent back to a client, most of the
#	time, it will be a file and the file is being sent back
#	asynchronously.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	sock	Socket to client.
#
# Results:
#	None.
#
# Side Effects:
#	Copy content of local file to requesting socket!
proc ::minihttpd::__push { port sock } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server
	
	set idx [lsearch $Server(clients) $sock]
	if { $idx >= 0 } {
	    set varname "::minihttpd::Client_${port}_${sock}"
	    upvar \#0 $varname Client

	    set Client(interndata) ""
	    set mypath ""
	    set myurl [fullurl $port $Client(url) mypath]

	    if { [file isdirectory $mypath] } {
		__dirlisting $port $sock $mypath [__URLtoString $Client(url)]
	    }

	    if {[string length $mypath] == 0} {
		__push_error $port $sock 400 "$Client(url) invalid path"
		return
	    }

	    if { $Client(interndata) != "" } {
		    puts $sock "HTTP/1.0 200 Data follows"
		    puts $sock "Date: [__fmtdate [clock seconds]]"
		    puts $sock \
			"Last-Modified: [__fmtdate [file mtime $mypath]]"
		    puts $sock "Content-Type: text/html"
		    puts $sock \
			"Content-Length: [string length $Client(interndata)]"
		    puts $sock ""
		    if { $Client(proto) == "HEAD" } {
			__finish $port $mypath "" $sock 0
		    } else {
			fconfigure $sock -translation auto \
			    -blocking $Server(-sockblock)
			puts -nonewline $sock $Client(interndata)
			__finish $port $mypath "" $sock 0
		    }
	    } else {
		if {![catch {open $mypath} in]} {
		    puts $sock "HTTP/1.0 200 Data follows"
		    puts $sock "Date: [__fmtdate [clock seconds]]"
		    puts $sock \
			"Last-Modified: [__fmtdate [file mtime $mypath]]"
		    puts $sock "Content-Type: [::mimetype::guess $mypath]"
		    puts $sock "Content-Length: [file size $mypath]"
		    puts $sock ""
		    if { $Client(proto) == "HEAD" } {
			__finish $port $mypath "" $sock 0
		    } else {
			fconfigure $sock -translation binary \
			    -blocking $Server(-sockblock)
			fconfigure $in -translation binary -blocking 1
			fcopy $in $sock \
			    -command [list ::minihttpd::__finish \
					  $port $mypath $in $sock]
		    }
		} else {
		    __push_error $port $sock 404 "$Client(url) $in"
		}
	    }
	} else {
	    ${log}::warn "$sock is not a recognised client of $port"
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}


# ::minihttpd::__finish -- Finish serving request
#
#	This command is called back when the content of a file has
#	been copied to the requesting client socket.  The client is
#	disconnected and the transaction is logged.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	mypath	Path to file that was copied
#	in	File descriptor to file being copied (empty for HEAD reqs)
#	out	Socket to client.
#	bytes	Number of bytes that were copied.
#	error	Non empty and containing an explanation of errors.
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::minihttpd::__finish { port mypath in out bytes { error {} } } {
    # Close file descriptor of file being sent.
    if { $in != "" } {
	::close $in
    }
    
    # Scream on error, log transaction.
    if { $error != "" } {
	if { [string match "*connection reset*peer*" $error] } {
	    __translog $port $out Error "Connection reset by peer on $mypath"
	} else {
	    __translog $port $out Error "Copying data for $mypath failed"
	}
    } else {
	__translog $port $out Done "$mypath"
    }
    
    # Close connection to client.
    __disconnect $port $out
}


# ::minihttpd::config -- Configure a server
#
#	This command set or get the options of a server.
#
# Arguments:
#	port	Port of server
#	args	list of options
#
# Results:
#	Return all options, the option requested or set the options
#
# Side Effects:
#	None.
proc ::minihttpd::config { port args } {
    variable HTTPD
    variable log

    # Check that this is one of our connections
    set idx [lsearch $HTTPD(servers) $port]
    if { $idx < 0 } {
	${log}::warn "Server $port is not valid"
	return -code error "Identifier invalid"
    }

    set varname "::minihttpd::Server_${port}"
    upvar \#0 $varname Server

    set o [lsort [array names Server "-*"]]

    if { [llength $args] == 0 } {      ;# Return all results
	set result ""
	foreach name $o {
	    lappend result $name $Server($name)
	}
	return $result
    }

    foreach {opt value} $args {        ;# Get onr or set some
	if { [lsearch $o $opt] == -1 } {
	    return -code error "Unknown option $opt, must be: [join $o ", " ]"
	}
	if { [llength $args] == 1 } {  ;# Get one config value
	    return $Server($opt)
	}
	set Server($opt) $value         ;# Set the config value
    }
}



# ::minihttpd::defaults -- Set/Get defaults for all new connections
#
#	This command sets or gets the defaults options for all new
#	connections, it will not perpetrate on existing pending
#	connections, use ::minihttpd::config instead.
#
# Arguments:
#	args	List of -key value or just -key to get value
#
# Results:
#	Return all options, the option requested or set the options
#
# Side Effects:
#	None.
proc ::minihttpd::defaults { args } {
    variable HTTPD
    variable log

    set o [lsort [array names HTTPD "-*"]]

    if { [llength $args] == 0 } {      ;# Return all results
	set result ""
	foreach name $o {
	    lappend result $name $HTTPD($name)
	}
	return $result
    }

    foreach {opt value} $args {        ;# Get onr or set some
	if { [lsearch $o $opt] == -1 } {
	    return -code error "Unknown option $opt, must be: [join $o ,]"
	}
	if { [llength $args] == 1 } {  ;# Get one config value
	    return $HTTPD($opt)
	}
	set HTTPD($opt) $value           ;# Set the config value
    }
}


# ::minihttpd::__log -- Handle logging.
#
#	This command will log to the log file associated to the server
#	if there was such.  It will also log through the logger
#	module, at the "info" level.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	txt	Text for line.
#
# Results:
#	None.
#
# Side Effects:
#	Will possibly write to the log file.
proc ::minihttpd::__log { port txt } {
    variable HTTPD
    variable log

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server

	if { $Server(-logfile) != "" } {
	    if { [catch {open $Server(-logfile) "a+"} fdes] == 0} {
		puts $fdes $txt
		::close $fdes
	    } else {
		${log}::warn "Could not open $Server(-logfile) for logging"
	    }
	}
	${log}::info "HTTP server \#$port: $txt"
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }	
}


# ::minihttpd::__push_error -- Push back error to client.
#
#	This command will send a formatted HTTP error message to the
#	client, explaining the error.
#
# Arguments:
#	port	Port number of one of our HTTP servers.
#	sock	Socket to client
#	code	HTTP error message
#	errmsg	Explanation for the error.
#
# Results:
#	None.
#
# Side Effects:
#	None.
proc ::minihttpd::__push_error { port sock code errmsg } {
    variable HTTPD
    variable log
    variable HTTPD_errors

    set idx [lsearch $HTTPD(servers) $port]
    if { $idx >= 0 } {
	set varname "::minihttpd::Server_${port}"
	upvar \#0 $varname Server
	
	set idx [lsearch $Server(clients) $sock]
	if { $idx >= 0 } {
	    set varname "::minihttpd::Client_${port}_${sock}"
	    upvar \#0 $varname Client

	    append Client(url) ""
	    set message "<title>Error: $code</title>Error <b>$Client(url): $HTTPD_errors($code)</b>."
	    puts $sock "HTTP/1.0 $code $HTTPD_errors($code)"
	    puts $sock "Date: [__fmtdate [clock seconds]]"
	    puts $sock "Content-Length: [string length $message]"
	    puts $sock ""
	    puts $sock $message
	    flush $sock
	    __translog $port $sock Error $message
	    __disconnect $port $sock
	} else {
	    ${log}::warn "$sock is not a recognised client of $port"
	}
    } else {
	${log}::warn "Not listening for HTTP connections on $port!"
    }
}

# ::minihttpd::__URLtoString -- Decode url-encoded strings
#
#	This command decodes a url-encoded string and returns its
#	decoded equivalent.
#
# Arguments:
#	data	String to be decode.
#
# Results:
#	Returns the decoded string.
#
# Side Effects:
#	None.
proc ::minihttpd::__URLtoString {data} {
    regsub -all {([][$\\])} $data {\\\1} data
    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
    return [subst $data]
}


# ::minihttpd::__StringToURL -- Encode strings for URL communication
#
#	This command encodes a Tcl (Utf8) string into a string that is
#	valid as a URL specification.
#
# Arguments:
#	data	String to be decode.
#
# Results:
#	Returns the encoded string.
#
# Side Effects:
#	None.
proc ::minihttpd::__StringToURL {data} {
    set len [string length $data]
    set res ""
    for { set i 0 } { $i < $len } { incr i } {
	set char [string index $data $i]
	if { [string match "\[0-9a-zA-Z\]" $char] || [string is punc $char] } {
	    append res $char
	} else {
	    append res "[format "%%%02x" [scan $char %c]]"
	}
    }
    return $res
}


# ::minihttpd::__friendly_datasize -- User friendly data size pretty format
#
#	This command provides a user friendly representation of a
#	number of bytes.  Bytes are automatically converted to Kbytes,
#	Mbytes, etc.
#
# Arguments:
#	size	Size to be pretty printed
#
# Results:
#	Returns a user friendly representation of the size.
#
# Side Effects:
#	None.
proc ::minihttpd::__friendly_datasize { size } {
    if { $size < 1024 } {
	set sz [format "%7d" $size]
	return "$sz B "
    } elseif { $size < [expr 1024 * 1024] } {
	set sz [format "%.2f" [expr double($size) / 1024]]
	return "$sz KB"
    } elseif { $size < [ expr 1024 * 1024 * 1024] } {
	set sz [format "%.2f" [expr double($size) / 1024 / 1024 ]]
	return "$sz MB"	
    } elseif { $size < [ expr 1024 * 1024 * 1024 * 1024 ] } {
	set sz [format "%.2f" [expr double($size) / 1024 / 1024 / 1024]]
	return "$sz GB"
    } else {
	set sz [format "%.2f" \
		    [expr double($size) / 1024 / 1024 / 1024 / 1024]]
	return "$sz TB"
    }
}

# ::minihttpd::__fmtdate -- HTTP data formatting
#
#	This command generates a date string in HTTP format
#
# Arguments:
#	clicks	Time in seconds since a known period of time.
#
# Results:
#	Returns the formatted date.
#
# Side Effects:
#	None.
proc ::minihttpd::__fmtdate {clicks} {
    return [clock format $clicks -gmt 1 -format {%a, %d %b %Y %T %Z}]
}


# ::minihttpd::__translog -- Transaction log.
#
#	This command log an HTTP transaction through the
#	::minihttpd::__log mechanism.
#
# Arguments:
#	port	Port number of one of our servers.
#	sock	Sock to one of its clients.
#	reason	Short name of transaction
#	args	Additional information for transaction.
#
# Results:
#	None.
#
# Side Effects:
#	Will possibly write to the log file.
proc ::minihttpd::__translog { port sock reason args } {
    variable HTTPD

    set logstr "\[[clock format [clock seconds] -format $HTTPD(dateformat)]\]"
    set sockinfo [fconfigure $sock -peername]
    append logstr " \[[lindex $sockinfo 1]:[lindex $sockinfo 2]\] "
    append logstr " \[$reason\] "
    append logstr "[join $args { }]"
    __log $port $logstr
}