/v2/testdata/_tcl8.6.8/pkgs/thread2.8.2/tcl/phttpd/phttpd.tcl
TCL | 686 lines | 294 code | 84 blank | 308 comment | 36 complexity | 9e30fe2563f34eb23bcda900ad2d0f0d MD5 | raw file
- #
- # phttpd.tcl --
- #
- # Simple Sample httpd/1.0 server in 250 lines of Tcl.
- # Stephen Uhler / Brent Welch (c) 1996 Sun Microsystems.
- #
- # Modified to use namespaces, direct url-to-procedure access
- # and thread pool package. Grown little larger since ;)
- #
- # Usage:
- # phttpd::create port
- #
- # port Tcp port where the server listens
- #
- # Example:
- #
- # # tclsh8.4
- # % source phttpd.tcl
- # % phttpd::create 5000
- # % vwait forever
- #
- # Starts the server on the port 5000. Also, look at the Httpd array
- # definition in the "phttpd" namespace declaration to find out
- # about other options you may put on the command line.
- #
- # You can use: http://localhost:5000/monitor URL to test the
- # server functionality.
- #
- # Copyright (c) 2002 by Zoran Vasiljevic.
- #
- # See the file "license.terms" for information on usage and
- # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- # -----------------------------------------------------------------------------
- package require Tcl 8.4
- package require Thread 2.5
- #
- # Modify the following in order to load the
- # example Tcl implementation of threadpools.
- # Per default, the C-level threadpool is used.
- #
- if {0} {
- eval [set TCL_TPOOL {source ../tpool/tpool.tcl}]
- }
- namespace eval phttpd {
- variable Httpd; # Internal server state and config params
- variable MimeTypes; # Cache of file-extension/mime-type
- variable HttpCodes; # Portion of well-known http return codes
- variable ErrorPage; # Format of error response page in html
- array set Httpd {
- -name phttpd
- -vers 1.0
- -root "."
- -index index.htm
- }
- array set HttpCodes {
- 400 "Bad Request"
- 401 "Not Authorized"
- 404 "Not Found"
- 500 "Server error"
- }
- array set MimeTypes {
- {} "text/plain"
- .txt "text/plain"
- .htm "text/html"
- .htm "text/html"
- .gif "image/gif"
- .jpg "image/jpeg"
- .png "image/png"
- }
- set ErrorPage {
- <title>Error: %1$s %2$s</title>
- <h1>%3$s</h1>
- <p>Problem in accessing "%4$s" on this server.</p>
- <hr>
- <i>%5$s/%6$s Server at %7$s Port %8$s</i>
- }
- }
- #
- # phttpd::create --
- #
- # Start the server by listening for connections on the desired port.
- #
- # Arguments:
- # port
- # args
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::create {port args} {
- variable Httpd
- set arglen [llength $args]
- if {$arglen} {
- if {$arglen % 2} {
- error "wrong \# args, should be: key1 val1 key2 val2..."
- }
- set opts [array names Httpd]
- foreach {arg val} $args {
- if {[lsearch $opts $arg] == -1} {
- error "unknown option \"$arg\""
- }
- set Httpd($arg) $val
- }
- }
- #
- # Create thread pool with max 8 worker threads.
- #
- if {[info exists ::TCL_TPOOL] == 0} {
- #
- # Using the internal C-based thread pool
- #
- set initcmd "source ../phttpd/phttpd.tcl"
- } else {
- #
- # Using the Tcl-level hand-crafted thread pool
- #
- append initcmd "source ../phttpd/phttpd.tcl" \n $::TCL_TPOOL
- }
- set Httpd(tpid) [tpool::create -maxworkers 8 -initcmd $initcmd]
- #
- # Start the server on the given port. Note that we wrap
- # the actual accept with a helper after/idle callback.
- # This is a workaround for a well-known Tcl bug.
- #
- socket -server [namespace current]::_Accept $port
- }
- #
- # phttpd::_Accept --
- #
- # Helper procedure to solve Tcl shared-channel bug when responding
- # to incoming connection and transfering the channel to other thread(s).
- #
- # Arguments:
- # sock incoming socket
- # ipaddr IP address of the remote peer
- # port Tcp port used for this connection
- #
- # Side Effects:
- # None.
- #
- # Results:
- # None.
- #
- proc phttpd::_Accept {sock ipaddr port} {
- after idle [list [namespace current]::Accept $sock $ipaddr $port]
- }
- #
- # phttpd::Accept --
- #
- # Accept a new connection from the client.
- #
- # Arguments:
- # sock
- # ipaddr
- # port
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Accept {sock ipaddr port} {
- variable Httpd
- #
- # Setup the socket for sane operation
- #
- fconfigure $sock -blocking 0 -translation {auto crlf}
- #
- # Detach the socket from current interpreter/tnread.
- # One of the worker threads will attach it again.
- #
- thread::detach $sock
- #
- # Send the work ticket to threadpool.
- #
- tpool::post -detached $Httpd(tpid) [list [namespace current]::Ticket $sock]
- }
- #
- # phttpd::Ticket --
- #
- # Job ticket to run in the thread pool thread.
- #
- # Arguments:
- # sock
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Ticket {sock} {
- thread::attach $sock
- fileevent $sock readable [list [namespace current]::Read $sock]
- #
- # End of processing is signalized here.
- # This will release the worker thread.
- #
- vwait [namespace current]::done
- }
- #
- # phttpd::Read --
- #
- # Read data from client and parse incoming http request.
- #
- # Arguments:
- # sock
- #
- # Side Effects:
- # None.
- #
- # Results:
- # None.
- #
- proc phttpd::Read {sock} {
- variable Httpd
- variable data
- set data(sock) $sock
- while {1} {
- if {[catch {gets $data(sock) line} readCount] || [eof $data(sock)]} {
- return [Done]
- }
- if {![info exists data(state)]} {
- set pat {(POST|GET) ([^?]+)\??([^ ]*) HTTP/1\.[0-9]}
- if {[regexp $pat $line x data(proto) data(url) data(query)]} {
- set data(state) mime
- continue
- } else {
- Log error "bad request line: (%s)" $line
- Error 400
- return [Done]
- }
- }
- # string compare $readCount 0 maps -1 to -1, 0 to 0, and > 0 to 1
- set state [string compare $readCount 0],$data(state),$data(proto)
- switch -- $state {
- "0,mime,GET" - "0,query,POST" {
- Respond
- return [Done]
- }
- "0,mime,POST" {
- set data(state) query
- set data(query) ""
- }
- "1,mime,POST" - "1,mime,GET" {
- if [regexp {([^:]+):[ ]*(.*)} $line dummy key value] {
- set data(mime,[string tolower $key]) $value
- }
- }
- "1,query,POST" {
- append data(query) $line
- set clen $data(mime,content-length)
- if {($clen - [string length $data(query)]) <= 0} {
- Respond
- return [Done]
- }
- }
- default {
- if [eof $data(sock)] {
- Log error "unexpected eof; client closed connection"
- return [Done]
- } else {
- Log error "bad http protocol state: %s" $state
- Error 400
- return [Done]
- }
- }
- }
- }
- }
- #
- # phttpd::Done --
- #
- # Close the connection socket
- #
- # Arguments:
- # s
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Done {} {
- variable done
- variable data
- close $data(sock)
- if {[info exists data]} {
- unset data
- }
- set done 1 ; # Releases the request thread (See Ticket procedure)
- }
- #
- # phttpd::Respond --
- #
- # Respond to the query.
- #
- # Arguments:
- # s
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Respond {} {
- variable data
- if {[info commands $data(url)] == $data(url)} {
- #
- # Service URL-procedure
- #
- if {[catch {
- puts $data(sock) "HTTP/1.0 200 OK"
- puts $data(sock) "Date: [Date]"
- puts $data(sock) "Last-Modified: [Date]"
- } err]} {
- Log error "client closed connection prematurely: %s" $err
- return
- }
- if {[catch {$data(url) data} err]} {
- Log error "%s: %s" $data(url) $err
- }
- } else {
- #
- # Service regular file path
- #
- set mypath [Url2File $data(url)]
- if {![catch {open $mypath} i]} {
- if {[catch {
- puts $data(sock) "HTTP/1.0 200 OK"
- puts $data(sock) "Date: [Date]"
- puts $data(sock) "Last-Modified: [Date [file mtime $mypath]]"
- puts $data(sock) "Content-Type: [ContentType $mypath]"
- puts $data(sock) "Content-Length: [file size $mypath]"
- puts $data(sock) ""
- fconfigure $data(sock) -translation binary -blocking 0
- fconfigure $i -translation binary
- fcopy $i $data(sock)
- close $i
- } err]} {
- Log error "client closed connection prematurely: %s" $err
- }
- } else {
- Log error "%s: %s" $data(url) $i
- Error 404
- }
- }
- }
- #
- # phttpd::ContentType --
- #
- # Convert the file suffix into a mime type.
- #
- # Arguments:
- # path
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::ContentType {path} {
- # @c Convert the file suffix into a mime type.
- variable MimeTypes
- set type "text/plain"
- catch {set type $MimeTypes([file extension $path])}
- return $type
- }
- #
- # phttpd::Error --
- #
- # Emit error page
- #
- # Arguments:
- # s
- # code
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Error {code} {
- variable Httpd
- variable HttpCodes
- variable ErrorPage
- variable data
- append data(url) ""
- set msg \
- [format $ErrorPage \
- $code \
- $HttpCodes($code) \
- $HttpCodes($code) \
- $data(url) \
- $Httpd(-name) \
- $Httpd(-vers) \
- [info hostname] \
- 80 \
- ]
- if {[catch {
- puts $data(sock) "HTTP/1.0 $code $HttpCodes($code)"
- puts $data(sock) "Date: [Date]"
- puts $data(sock) "Content-Length: [string length $msg]"
- puts $data(sock) ""
- puts $data(sock) $msg
- } err]} {
- Log error "client closed connection prematurely: %s" $err
- }
- }
- #
- # phttpd::Date --
- #
- # Generate a date string in HTTP format.
- #
- # Arguments:
- # seconds
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Date {{seconds 0}} {
- # @c Generate a date string in HTTP format.
- if {$seconds == 0} {
- set seconds [clock seconds]
- }
- clock format $seconds -format {%a, %d %b %Y %T %Z} -gmt 1
- }
- #
- # phttpd::Log --
- #
- # Log an httpd transaction.
- #
- # Arguments:
- # reason
- # format
- # args
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Log {reason format args} {
- set messg [eval format [list $format] $args]
- set stamp [clock format [clock seconds] -format "%d/%b/%Y:%H:%M:%S"]
- puts stderr "\[$stamp\]\[-thread[thread::id]-\] $reason: $messg"
- }
- #
- # phttpd::Url2File --
- #
- # Convert a url into a pathname.
- #
- # Arguments:
- # url
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::Url2File {url} {
- variable Httpd
- lappend pathlist $Httpd(-root)
- set level 0
- foreach part [split $url /] {
- set part [CgiMap $part]
- if [regexp {[:/]} $part] {
- return ""
- }
- switch -- $part {
- "." { }
- ".." {incr level -1}
- default {incr level}
- }
- if {$level <= 0} {
- return ""
- }
- lappend pathlist $part
- }
- set file [eval file join $pathlist]
- if {[file isdirectory $file]} {
- return [file join $file $Httpd(-index)]
- } else {
- return $file
- }
- }
- #
- # phttpd::CgiMap --
- #
- # Decode url-encoded strings.
- #
- # Arguments:
- # data
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::CgiMap {data} {
- regsub -all {\+} $data { } 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]
- }
- #
- # phttpd::QueryMap --
- #
- # Decode url-encoded query into key/value pairs.
- #
- # Arguments:
- # query
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc phttpd::QueryMap {query} {
- set res [list]
- regsub -all {[&=]} $query { } query
- regsub -all { } $query { {} } query; # Othewise we lose empty values
- foreach {key val} $query {
- lappend res [CgiMap $key] [CgiMap $val]
- }
- return $res
- }
- #
- # monitor --
- #
- # Procedure used to test the phttpd server. It responds on the
- # http://<hostname>:<port>/monitor
- #
- # Arguments:
- # array
- #
- # Side Effects:
- # None..
- #
- # Results:
- # None.
- #
- proc /monitor {array} {
- upvar $array data ; # Holds the socket to remote client
- #
- # Emit headers
- #
- puts $data(sock) "HTTP/1.0 200 OK"
- puts $data(sock) "Date: [phttpd::Date]"
- puts $data(sock) "Content-Type: text/html"
- puts $data(sock) ""
- #
- # Emit body
- #
- puts $data(sock) [subst {
- <html>
- <body>
- <h3>[clock format [clock seconds]]</h3>
- }]
- after 1 ; # Simulate blocking call
- puts $data(sock) [subst {
- </body>
- </html>
- }]
- }
- # EOF $RCSfile: phttpd.tcl,v $
- # Emacs Setup Variables
- # Local Variables:
- # mode: Tcl
- # indent-tabs-mode: nil
- # tcl-basic-offset: 4
- # End: