A Tcl Web server. This application assumes that a mime.typ file is in the launch directory.
#=========================================================================== # WEBSERVR.TCL # # Copyright (c) 1997 Eolas Technologies Inc. # Freely modifiable/redistributable under the "Standard Tcl License" # See http://www.eolas.com/tcl/license.txt for details # # This file is used to implement a mini http server listening on port 8080 # # usage: # wish webservr.tcl ?-webdir? ?-logdir ? ?-port ? # # defaults: # webdir = "." # logdir = "." # port = 8080 #=========================================================================== # -- make certain that we're running against the appropriate release level global tcl_version if {[info exists tcl_version] == 0 || $tcl_version < 7.5} { error "webservr: This program requires Tcl 7.5 or higher" } global auto_path env source spynergy.tcl set mimepath "mime.typ" if {(![file exists $mimepath]) || (![file readable $mimepath])} { error "webservr: could not find $mimepath file" } if {[info commands fcopy] == ""} { if {[info commands unsupported0] != ""} { rename unsupported0 fcopy } else { error "webservr: could not find the fcopy command" } } #--------------------------------------------------------------------------- # -- user configurable parameters set _HTTPD(serversocket) 8080 set _HTTPD(use_log_files) 1 set _HTTPD(logdir) "." set _HTTPD(webdir) "." set _HTTPD(access_log) "access.log" set _HTTPD(agent_log) "agent.log" set _HTTPD(error_log) "error.log" set _HTTPD(pid_file) "webservr.pid" #-------------------- # -- set up GUI set align_list "" #---------- ### START DEFINITION FOR: .top0 set Name .top0 catch "destroy .top0" global targetmain$Name inGUIbuilder set targetmain$Name 1 if {[set targetmain$Name] && (![info exists inGUIbuilder])} { frame $Name -height 36 -width 170 pack $Name } else { toplevel $Name wm title $Name "top0" wm geometry $Name 170x36 set Toppos($Name) 0 set Topgeom($Name) 1 } ########## # #-------------------- # -- set up GUI set Name .top0 catch "destroy .top0" toplevel $Name wm title $Name "Tcl Web Server" set Parent .top0 set Name $Parent.m1 button $Name -background bisque \ -relief raised \ -text "Shut down server" -command "exit" \ -activebackground red pack $Name -side top # -- read in the contents of the mime file set fd [open $mimepath r] while {![eof $fd]} { set line [gets $fd] if {[string index $line 0] != "#" && \ [string index $line 0] != " " && \ [string index $line 0] != "\n" && \ [string index $line 0] != "\t"} { set content [lindex $line 0] set exts [lrange $line 1 end] foreach ext $exts { if {[string index $ext 0] != "#"} { set _HTTPD(mime~~$ext) $content } } } } close $fd unset fd unset mimepath # -- process command line options if {[info exists argc]} { set i 0 while {$i < $argc} { switch -glob -- [string tolower [lindex $argv $i]] { -logdir { incr i set _HTTPD(logdir) [lindex $argv $i] set path [file split [eval file join [file split [pwd]] [file split $_HTTPD(logdir)]]] set outpath "" foreach item $path { switch -exact -- $item { . {} .. { set outpath [lrange $outpath 0 [expr [llength $outpath] - 2]] } default {lappend outpath $item} } } set _HTTPD(logdir) [eval file join [split $outpath " "]] if {(![file isdirectory $_HTTPD(logdir)]) || (![file writable $_HTTPD(logdir)])} { error "webservr: logging directory may not be written to" } incr i } -webdir { incr i set _HTTPD(webdir) [lindex $argv $i] set path [file split [eval file join [file split [pwd]] [file split $_HTTPD(webdir)]]] set outpath "" foreach item $path { switch -exact -- $item { . {} .. { set outpath [lrange $outpath 0 [expr [llength $outpath] - 2]] } default {lappend outpath $item} } } set _HTTPD(webdir) [eval file join [split $outpath " "]] if {(![file isdirectory $_HTTPD(webdir)]) || (![file writable $_HTTPD(webdir)])} { error "webservr: WRB directory may not be written to" } incr i } -port { incr i set _HTTPD(serversocket) [lindex $argv $i] incr i } default { puts stderr "webservr: unrecognized option \[[lindex $argv $i]\]" incr i } } } } set _HTTPD(access_log) "$_HTTPD(logdir)/$_HTTPD(access_log)" set _HTTPD(agent_log) "$_HTTPD(logdir)/$_HTTPD(agent_log)" set _HTTPD(error_log) "$_HTTPD(logdir)/$_HTTPD(error_log)" set _HTTPD(pid_file) "$_HTTPD(logdir)/webservr.pid" # -- don't touch these set _HTTPD(serverfd) "" set _HTTPD(activesessions) 0 #---------- # _httpd_log_error - put an error message in the error log file proc _httpd_log_error {sock message} { global _HTTPD set d [clock format [clock seconds] -gmt 1] if {$_HTTPD(use_log_files)} { puts $_HTTPD($sock~~errorfd) "\[$d\] webservr: $message" flush $_HTTPD($sock~~errorfd) } else { puts stderr "\[$d\] WRBhttpd: $message" } } #---------- # _httpd_log_access - put an access entry into the access log proc _httpd_log_access {sock ip getmessage code length} { global _HTTPD set d [clock format [clock seconds] -gmt 1] if {$_HTTPD(use_log_files)} { puts $_HTTPD($sock~~accessfd) "$ip - - \[$d\] \"$getmessage\" $code $length" flush $_HTTPD($sock~~accessfd) } } #---------- # _httpd_log_agent - put an entry into the agent log proc _httpd_log_agent {sock agent} { global _HTTPD if {$_HTTPD(use_log_files)} { puts $_HTTPD($sock~~agentfd) "$agent" flush $_HTTPD($sock~~agentfd) } } #---------- # _httpd_start - initiate the WRB httpd server proc _httpd_start {} { global _HTTPD # -- create/overwrite the pid file set pidfd [open $_HTTPD(pid_file) w] puts $pidfd "[pid]" flush $pidfd close $pidfd set outfd "dummy" # -- create a listening socket if {[catch "socket -server [list "_httpd_accept $_HTTPD(serversocket)"] $_HTTPD(serversocket)" outfd]} { puts stderr "webservr: Unable to open a server socket" catch "close $outfd" exit 1 } if {[string range $outfd 0 3] != "sock"} { puts stderr "webservr: Unable to open a server socket" catch "close $outfd" exit 1 } } #---------- # _httpd_accept -- accepts a client connection to http server proc _httpd_accept {listener sock addr port} { global _HTTPD set _HTTPD(serverfd) $sock set _HTTPD($sock~~clientipaddr) $addr incr _HTTPD(activesessions) # -- open log files, append write mode if {$_HTTPD(use_log_files)} { set _HTTPD($sock~~errorfd) [open $_HTTPD(error_log) a] set _HTTPD($sock~~accessfd) [open $_HTTPD(access_log) a] set _HTTPD($sock~~agentfd) [open $_HTTPD(agent_log) a] } if {[catch "fconfigure $sock -translation auto"]} { _httpd_log_error $sock "$sock connection abnormally terminated in _httpd_accept" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } if {[catch "fileevent $sock readable [list "_httpd_process_request $sock"]"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_accept" _httpd_cleanup_connection $sock } } #---------- # _httpd_cleanup_connection -- clean up internal state, remove handlers proc _httpd_cleanup_connection {sock} { global _HTTPD incr _HTTPD(activesessions) -1 if {$_HTTPD(use_log_files)} { close $_HTTPD($sock~~errorfd) close $_HTTPD($sock~~agentfd) close $_HTTPD($sock~~accessfd) } foreach element [array names _HTTPD $sock~~*] { unset _HTTPD($element) } } #---------- # _httpd_process_request -- manage the server side conversion to a client proc _httpd_process_request {sock} { global _HTTPD set _HTTPD($sock~~headf) 0 # -- read and process the client's request set done 0 set request "" while {!$done} { if {[catch "gets $sock" line]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } if {[string length "$line"] == 0} { set done 1 } else { append request "$line\n" } } foreach line [split $request "\n"] { switch -glob -- [string tolower [lindex $line 0]] { get { set _HTTPD($sock~~headf) 0 set url [lindex $line 1] set path [split $url "/"] if {[lindex $path 0] == ""} {set path [lrange $path 1 end]} # -- handle request for a WRB instead of from file if {[string tolower [lindex $path 0]] != "wrb"} { set path [lrange $path 0 end] set _HTTPD($sock~~file) [eval file join [file split $_HTTPD(webdir)] $path] if {[file isdirectory $_HTTPD($sock~~file)]} { set _HTTPD($sock~~file) [eval file join [file split $_HTTPD($sock~~file)] "index.html"] } # -- see if the file exists and can be read if {(![file exists $_HTTPD($sock~~file)]) || \ (![file readable $_HTTPD($sock~~file)]) || \ ([file isdirectory $_HTTPD($sock~~file)])} { _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 404 0 _httpd_log_error $sock "access to $url failed for $_HTTPD($sock~~clientipaddr), reason: No valid filename matching URL: $url from -" _httpd_not_found $sock "$line" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" _httpd_cleanup_connection $sock return } # -- see if the file goes outside of the webdir path set path [file split [eval file join [file split $_HTTPD(webdir)] [file split $_HTTPD($sock~~file)]]] set outpath "" foreach item $path { switch -exact -- $item { . {} .. { set outpath [lrange $outpath 0 [expr [llength $outpath] - 2]] } default {lappend outpath $item} } } set _HTTPD($sock~~file) [eval file join [split $outpath " "]] # -- prohibit the fetching of the log files set filename [lindex [file split $_HTTPD($sock~~file)] end] if {$filename == "access.log" || \ $filename == "error.log" || \ $filename == "agent.log"} { _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 404 0 _httpd_log_error $sock "access to $url failed for $_HTTPD($sock~~clientipaddr), reason: No valid filename matching URL: $url from -" _httpd_not_found $sock "$line" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" _httpd_cleanup_connection $sock return } if {[string first $_HTTPD(webdir) $_HTTPD($sock~~file)] == -1} { # -- the path specified goes outside of the hierarchy _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 404 0 _httpd_log_error $sock "access to $url failed for $_HTTPD($sock~~clientipaddr), reason: No valid filename matching URL: $url from -" _httpd_not_found $sock "$line" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" _httpd_cleanup_connection $sock return } set text "" _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 200 [string length "$text"] _httpd_send_it $sock $_HTTPD($sock~~file) "" } else { set _HTTPD($sock~~file) "" if {[string last "/" $url]} {set url "/$url"} set key [string range $url [expr [string last "/" $url] + 1] \ [expr [string length $url] - 1]] if {"$key" == ""} {set key "index.html"} set text "[WRBgetsource "$key"]" if {[lsearch [WRBkeylist] "$key"] == -1 || "$text" == ""} { _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 404 0 _httpd_log_error $sock "access to $url failed for $_HTTPD($sock~~clientipaddr), reason: No keyname matching URL: $url from -" _httpd_not_found $sock "$line" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" _httpd_cleanup_connection $sock return } _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 200 [string length "$text"] _httpd_send_it $sock $key $text } } head { set _HTTPD($sock~~headf) 1 set url [lindex $line 1] if {[string last "/" $url]} {set url "/$url"} set key [string range $url [expr [string last "/" $url] + 1] \ [expr [string length $url] - 1]] if {"$key" == ""} {set key "index.html"} set text "[WRBgetsource "$key"]" if {[lsearch [WRBkeylist] "$key"] == -1 || "$text" == ""} { _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 404 0 _httpd_log_error $sock "access to $url failed for $_HTTPD($sock~~clientipaddr), reason: No keyname matching URL: $url from -" _httpd_not_found $sock "$url" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "fileevent $sock readable {}" catch "close $sock" _httpd_cleanup_connection $sock return } _httpd_log_access $sock $_HTTPD($sock~~clientipaddr) "$line" 200 [string length "$text"] _httpd_send_it $sock $key "$text" } user-agent: { _httpd_log_agent $sock "[lrange $line 1 end]" } default {} } } close $sock _httpd_cleanup_connection $sock } #---------- # _httpd_not_found -- return item not found message proc _httpd_not_found {sock item} { set d [clock format [clock seconds] -gmt 1] catch "fconfigure $sock -translation crlf -buffering full" catch "puts $sock [list "HTTP/1.0 404 Not Found"]" catch "puts $sock [list "Date: $d"]" catch "puts $sock [list "Server: webservr/1.0"]" catch "puts $sock [list "Content-type: text/html"]" catch "puts $sock {}" catch "puts $sock [list " 404 Not Found "]" catch "puts $sock [list "404 Not Found
"]" catch "puts $sock [list "The requested URL $item was not found on this server."]" catch "puts $sock [list ""]" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } } #---------- # _httpd_bad_request -- return bad request message proc _httpd_bad_request {sock item} { set d [clock format [clock seconds] -gmt 1] catch "fconfigure $sock -translation crlf -buffering full" catch "puts $sock [list "HTTP/1.0 400 Bad Request"]" catch "puts $sock [list "Date: $d"] catch "puts $sock [list "Server: webservr/1.0"]" catch "puts $sock [list "Content-type: text/html"]" catch "puts $sock {}" catch "puts $sock [list "400 Bad Request "]" catch "puts $sock [list "400 Bad Request
"]" catch "puts $sock [list "Your client sent a query that this server could"]" catch "puts $sock [list "not understand."]" catch "puts $sock [list "Reason: Invalid or unsupported method.
"]" catch "puts $sock [list ""]" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } } #---------- # _httpd_send_it -- send the requested item to the client proc _httpd_send_it {sock key item} { global _HTTPD if {$_HTTPD($sock~~file) != "" && "$item" == ""} { # -- file processing set _HTTPD($sock~~itemlen) [file size $_HTTPD($sock~~file)] set _HTTPD($sock~~item) "" } else { set _HTTPD($sock~~item) "[lindex $item 0]" set _HTTPD($sock~~itemlen) [string length "$_HTTPD($sock~~item)"] } set d [clock format [clock seconds] -gmt 1] catch "fconfigure $sock -translation crlf -buffering full" catch "puts $sock [list "HTTP/1.0 200 Document follows"]" catch "puts $sock [list "Date: $d"]" catch "puts $sock [list "Server: webservr/1.0"]" set ext [string tolower [string range [file extension $key] 1 end]] if {[info exists _HTTPD(mime~~$ext)]} { catch "puts $sock [list "Content-type: $_HTTPD(mime~~$ext)"]" } else { catch "puts $sock [list "Content-type: text/html"]" } catch "puts $sock [list "Last-modified: $d"]" catch "puts $sock [list "Content-length: $_HTTPD($sock~~itemlen)"]" catch "puts $sock {}" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } if {!$_HTTPD($sock~~headf)} { if {$_HTTPD($sock~~file) == $key && $item == ""} { catch "fconfigure $sock -translation binary -buffering full -blocking 1" catch "open $_HTTPD($sock~~file) r" fd catch "fconfigure $fd -translation binary -buffering full -blocking 1" if {[catch {fcopy $fd $sock} oops]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } catch "close $fd" set _HTTPD($sock~~donef) 1 } else { # -- send the requested WRB item in 4K chunks set _HTTPD($sock~~donef) 0 catch "fconfigure $sock -translation lf" catch "fconfigure $sock -buffering full" while {$_HTTPD($sock~~itemlen) > 0} { _httpd_send_buf $sock } } unset _HTTPD($sock~~donef) unset _HTTPD($sock~~item) unset _HTTPD($sock~~itemlen) unset _HTTPD($sock~~headf) } } #---------- # _httpd_send_buf -- transmit a buffer when the channel is writable proc _httpd_send_buf {sock} { global _HTTPD if {$_HTTPD($sock~~itemlen) > 0} { if {$_HTTPD($sock~~itemlen) > 32768} { set last 32767 } else { set last [expr $_HTTPD($sock~~itemlen) - 1] } set buf "[string range "$_HTTPD($sock~~item)" 0 $last]" catch "puts -nonewline $sock [list "$buf"]" if {[catch "flush $sock"]} { _httpd__error $sock "$sock connection abnormally terminated in _httpd_process_request" _httpd_cleanup_connection $sock catch "fileevent $sock readable {}" catch "close $sock" } set _HTTPD($sock~~item) "[string range $_HTTPD($sock~~item) [expr $last + 1] [expr $_HTTPD($sock~~itemlen) - 1]]" incr _HTTPD($sock~~itemlen) -[expr $last + 1] if {$_HTTPD($sock~~itemlen) <= 0} { set _HTTPD($sock~~donef) 1 } } } #========================================================================== # START UP THE SERVER #========================================================================== # -- start the http server global yzzyx _httpd_start vwait yzzyx