#
# 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:
#
#    # tclsh9.0
#    % 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.5-
package require thread 2.9-

#
# 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] < 0} {
		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: