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