proc mimetype.init {} {
global mimetype conf
# Loading mimetypes from file
foreach type [split [readfile $conf(typesfile)] \n] {
foreach suffix [lrange $type 1 end] {
set mimetype($suffix) [lindex $type 0]
}
}
}
proc mimetype.bysuffix {suffix} {
global mimetype
if [info exists mimetype($suffix)] {return $mimetype($suffix)}
return "text/plain"
}
proc http.date {timestamp} {
return "[lindex "Mon Tue Wed Thu Fri Sat Sun" [clock format $timestamp -format "%u"]], [clock format $timestamp -format "%d %b %Y %T GMT"]"
}
proc httpd {client remaddr remport} {
global modules
logexec "" 1 "Client connected $remaddr:$remport"
set clock1 [clock clicks]
# Processing remote request
gets $client req
fconfigure $client -encoding binary
set req [split [lindex $req 1] ?]
set module [string range [lindex $req 0] 1 end]
cgi:cgi2array [lindex $req 1] cgi
set header(Server) "WTorrent/0.0.1 Tcl8.4"
set header(Date) [http.date [clock seconds]]
set header(Content-Type) "text/html; charset=iso-8859-1"
set header(Connection) "close"
switch -glob [lindex $req 0] {
/torrent* {
set cgi(url) "http://www.btmon.com/[lindex $req 0]"
set body [surf]
}
default {
if [lsearch $modules $module]>=0 {
set body [$module]
} {
set body [httpd.file $req]
}
}
}
set header(Content-Length) [expr [string length $body]+[llength [split $body \n]]]
puts $client "HTTP/1.1 200 Ok"
foreach field [array names header] {
puts $client "${field}: $header($field)"
}
puts $client ""
puts -nonewline $client $body
# if [string match "text/html*" $header(Content-Type)] {
# set clock2 [clock clicks]
# puts $client "
I needed [format "%01.4f" [expr ($clock2-$clock1)/1001000.0]] seconds to fulfill your request."
# }
close $client
}
proc httpd.file {req} {
global conf
upvar header header status status
# Protect us from geeks
regsub -all {[\.]+} $req . req
regsub -all {[\[\];$]*} $req "" req
set file $conf(serverroot)/$req
logexec "" 0 "Requested file: $file"
if [string match */ $file] {
foreach index $conf(indexfiles) {
if [file readable $file$index] {set file $file$index; break}
}
}
if [file readable $file] {
set header(Content-Type) [mimetype.bysuffix [string range [file extension $file] 1 end]]
set header(Last-Modified) [http.date [file mtime $file]]
set status "200 OK"
return [readfile $file -encoding binary]
} {
set status "404 Not Found"
return [http.error 404 $req]
}
}
proc http.error {error args} {
global conf
set htmlout ""
htmlout {}
switch $error {
404 {
set title "404 Not Found"
set header "Not Found"
set body "The requested URL $args was not found on this server."
}
}
htmlout "$title"
htmlout "$header
"
htmlout "$body
"
htmlout "WTorrent/$conf(version) (Debian GNU/Linux) tcl8.4 Server at $conf(servername) Port $conf(serverport)"
htmlout ""
return $htmlout
}