36 line web server in TCL

web-server.tcl

array set env {PORT 8080 ROOT public_html DEFAULT index.html ME localhost:8080}
foreach t {image:png,gif,jpg=jpeg text:htm=html,txt=plain,css :pl=php=tcl=cgi} {
	foreach el [lrange [split $t :,] 1 end] {
		foreach ext [split $el =] {regsub {:.*=} $t=$el / mime(.$ext)}
	}
}
set match {(GET|POST) (/[^ ?]*)\??(\S*).*?\n(.*?)\n\n(.*)}
proc answer {sock from p2} {fileevent $sock readable [list serve $sock $from]}
proc serve {sock from} {
 	fconfigure $sock -blocking 0
	if {![regexp $::match [read $sock] to METHOD URL GET ENV POST]} return
  	fileevent $sock readable ""
	set url [string map {.. BAD ~ home/ %20 \ } $URL]
	set response "200 OK"
	set redirect "301 Moved Permanently\nLocation: http://$::env(ME)$url/"
	if {[file isdirectory [set name $::env(ROOT)$url]]} {	
		set name [file join $name $::env(DEFAULT)]
		if {![string match */ $url]} {set response redirect}
	}
	if {![file readable $name]} { set name $::env(ROOT)/404.tcl }
	set n [string tolower [file extension $name]]
	if {[catch {set m $::mime($n)}]} {set m "application/octet-stream"}
	if {$m eq "/cgi"} { 
		foreach x {METHOD URL GET ENV POST} {set ::env($x) [set $x]}
		set name "|$name" 
	} else {
		puts $sock "HTTP/1.0 $response\nContent-type: $m\n"
	}
	fconfigure [set inchan [open $name]] -translation binary
	fconfigure $sock -translation binary
	fcopy $inchan $sock -command "eval {close $inchan; close $sock ;#}"
	puts "$from [clock format [clock seconds]] [scan $to "%\[^\n\]"] $name"
	foreach x [array names ::env] { puts "env($x) is $::env($x)" }
}
puts "Socket [socket -server answer $env(PORT)] listening on port $env(PORT)"
vwait forever