# simple tcl web server - ddj version
# Copyright (c) 1998-1999 Sun Microsystems, by Stephen Uhler
# Code to accompany "Event Based Servers in TCL" srticle
# in Dr. Dobbs, Septemper 1999

# Accept a new request.  initialize event handlers and request state.

proc DDJaccept {root timelimit socket ip args} {
	upvar #0 $socket request
	array set request [list State start Root $root Ip $ip]
	fconfigure $socket -block 0 -translation {auto crlf}
	fileevent $socket readable [list DDJread $socket]
	set request(Cancel) [after $timelimit [list DDJtimeout $socket]]
}

# Data is available: read the request.

proc DDJread {socket} {
	upvar #0 $socket request

	# unexpected EOF - abort

	if {[eof $socket]} {
		puts stderr "$socket: Eof ([array get request])"
		close $socket
		after cancel $request(Cancel)
		unset request
	}

	switch $request(State) {
		start {			# Get HTTP request line
			gets $socket line
			if [regexp {(POST|GET|HEAD) ([^?]+)\??([^ ]*) HTTP/1.?} \
					$line {} request(Proto) request(Url) request(Query)] {
				set request(State) headers
			} else {
				DDJerror $socket "400 Bad Request" "Invalid request:$line"
			}
		}	
		headers {
			set count [gets $socket line]
			if {$count == 0} {	# end of headers
				catch {incr count $request(content-length)}
				if {$count > 0} {
					fconfigure $socket -translation {binary crlf}
					array set request [list data {} State body Count $count]
				} else {
					DDJrespond $socket
				}
			} elseif {[regexp {([^:]+):[ 	]*(.*)}  $line {} key value]} {
					set key [string tolower $key]
					if {[info exists request($key)]} {
						append request($key) ", " $value
					} else {
						set request($key) $value
					}
					set request(Key) $key
			} elseif {[regexp {^[ 	]+(.*)} $line {} value]} {
					append request($request(Key)) " " $value
			} else {
					DDJerror $socket "400 Bad Request" "Invalid header:$line"
			}
		}
		body {
			append request(Body) [read $socket $request(Count)]
			set request(Count) [expr {$request(content-length) - \
					[string length $request(Body)]}]
			if {$request(Count) == 0} {
				DDJrespond $socket
			}
		}
	}
}

# Request complete - return file.

proc DDJrespond {socket} {
	upvar #0 $socket request
	fileevent $socket readable {}
	after cancel $request(Cancel)
	set fileName [DDJurlToFile $request(Root) $request(Url)]
	puts stderr "Got $fileName"
	if {[file isdirectory $fileName]} {
		puts appending
		append fileName /index.html
	}
	puts stderr "Got $fileName"
	if {[file isfile $fileName]} {
		append response [DDJheaders "200 data Follows" \
				[DDJcontentType $fileName] \
				[file size $fileName]] \
				"Last-Modified: [DDJdate [file mtime $fileName]]\n" 
		puts $socket $response
		if {$request(Proto) != "HEAD"} {
			set in [open $fileName]
			fconfigure $socket -translation binary
			fconfigure $in -translation binary
			fcopy $in $socket -command [list DDJcopyDone $socket $in]
		} else {
			DDJcopyDone $sock ""
		}
	} else {
		DDJerror $socket "404 Not Found" "Can't find $request(Url)"
	}
}

# Done sending file - clean up state.

proc DDJcopyDone {socket fd size} {
	upvar #0 $socket request
	# puts stderr "[incr ::Ok] $request(Ip) $request(Url) ($size bytes)"
	catch {close $fd}
	close $socket
	# parray request
	unset request
}

# Request timeout - abort.

proc DDJtimeout {socket} {
	upvar #0 $socket request
	puts stderr "$socket: timeout ([array get request])"
	close $socket
	unset request
}

# Utility routines

array set DDJtypes {
	.txt text/plain  .html text/html  .gif image/gif  .jpg image/jpeg
}

# Convert file suffix into mime type.

proc DDJcontentType {fileName} {
	set type applcation/octet-stream
	catch {set type $::DDJtypes([file extension $fileName])}
	return $type
}

# Return standard http headers

proc DDJheaders {code type length} {
	append result "HTTP/1.0 $code\n" \
			"Server: TclMiniServer/1.0\n" \
			"Date: [DDJdate [clock seconds]]\n" \
			"Content-Type: $type\n" \
			"Content-Length: $length\n"
	return $result
}

# Return an error response.

proc DDJerror {socket code reason} {
	upvar #0 $socket request
	puts stderr "Error [incr ::Bad] $request(Ip) $reason"
	set body "<title>$code</title>Error <b>$code</b><br>Reason: $reason"
	append response [DDJheaders $code text/html [string length $body]] \
			"\n$body"
	catch {
		puts -nonewline $socket $response
		close $socket
	}
	after cancel $request(Cancel)
	unset request
}

# Generate a date string in HTTP format.

proc DDJdate {seconds} {
    return [clock format $seconds -format {%a, %d %b %Y %T %Z}]
}

# Convert a url into a file name.  Prevent url from walking past the
# document root.

proc DDJurlToFile {root url} {
	set path ""
	foreach part [split $url /] {
		set part [DDJdecode $part]
		switch -- $part {
			. {}
			.. {
				set path [lrange $path 0 [expr {[llength $path] - 2}]]
			}
			default {
				lappend path $part
			}
		}
	}
	return [eval file join [list $root] $path]
}

# Convert a www-url-encoded string into data.

proc DDJdecode {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]
}

proc bgerror {args} {
	puts stderr $::errorInfo
}

# Set global server properties and start the server.

set port 8080
set timeout 60000
set root [pwd]
set Ok 0
set Bad 0

socket -server [list DDJaccept $root $timeout] $port
vwait forever