debug "Failed on 500: [dict get $errdat -errorinfo]""
+ } finally {
+ catch {chan event readable $sock {}}
+ catch {chan event writeable $sock {}}
+ catch {chan close $sock}
+ }
+ }
+ }
+}
ADDED modules/httpd/build/server.man
Index: modules/httpd/build/server.man
==================================================================
--- /dev/null
+++ modules/httpd/build/server.man
@@ -0,0 +1,97 @@
+[section {Class ::httpd::server}]
+
+This class is the root object of the webserver. It is responsible
+for opening the socket and providing the initial connection negotiation.
+
+[list_begin definitions]
+[call constructor ?port [opt port]? ?myaddr [opt ipaddr]|all? ?server_string [opt string]? ?server_name [opt string]?]
+Build a new server object. [opt port] is the port to listen on
+
+[call method [cmd add_uri] [arg pattern] [arg dict]]
+Set the hander for a URI pattern. Information given in the [arg dict] is stored
+in the data structure the [cmd dispatch] method uses. If a field called
+[arg mixin] is given, that class will be mixed into the reply object immediately
+after construction.
+
+[call method [cmd connect] [arg sock] [arg ip] [arg port]]
+
+Reply to an open socket. This method builds a coroutine to manage the remainder
+of the connection. The coroutine's operations are driven by the [cmd Connect] method.
+
+[call method [cmd Connect] [arg uuid] [arg sock] [arg ip]]
+
+This method reads HTTP headers, and then consults the [cmd dispatch] method to
+determine if the request is valid, and/or what kind of reply to generate. Under
+normal cases, an object of class [cmd ::http::reply] is created.
+
+Fields the server are looking for in particular are:
+
+class: A class to use instead of the server's own [arg reply_class]
+
+mixin: A class to be mixed into the new object after construction.
+
+All other fields are passed along to the [cmd http_info] structure of the
+reply object.
+
+After the class is created and the mixin is mixed in, the server invokes the
+reply objects [cmd dispatch] method. This action passes control of the socket to
+the reply object. The reply object manages the rest of the transaction, including
+closing the socket.
+
+[call method [cmd counter] [arg which]]
+
+Increment an internal counter.
+
+[call method [cmd CheckTimeout]]
+
+Check open connections for a time out event.
+
+[call method [cmd dispatch] [arg header_dict]]
+
+Given a key/value list of information, return a data structure describing how
+the server should reply.
+
+[call method [cmd log] [arg args]]
+
+Log an event. The input for args is free form. This method is intended
+to be replaced by the user, and is a noop for a stock http::server object.
+
+[call method [cmd port_listening]]
+
+Return the actual port that httpd is listening on.
+
+[call method [cmd PrefixNormalize] [arg prefix]]
+
+For the stock version, trim trailing /'s and *'s from a prefix. This
+method can be replaced by the end user to perform any other transformations
+needed for the application.
+
+[call method [cmd start]]
+
+Open the socket listener.
+
+[call method [cmd stop]]
+
+Shut off the socket listener, and destroy any pending replies.
+
+[call method [cmd template] [arg page]]
+
+Return a template for the string [arg page]
+
+[call method [cmd TemplateSearch] [arg page]]
+
+Perform a search for the template that best matches [arg page]. This
+can include local file searches, in-memory structures, or even
+database lookups. The stock implementation simply looks for files
+with a .tml or .html extension in the [opt doc_root] directory.
+
+[call method [cmd Validate_Connection] [arg sock] [arg ip]]
+
+
+Given a socket and an ip address, return true if this connection should
+be terminated, or false if it should be allowed to continue. The stock
+implementation always returns 0. This is intended for applications to
+be able to implement black lists and/or provide security based on IP
+address.
+
+[list_end]
ADDED modules/httpd/build/server.tcl
Index: modules/httpd/build/server.tcl
==================================================================
--- /dev/null
+++ modules/httpd/build/server.tcl
@@ -0,0 +1,397 @@
+###
+# An httpd server with a template engine
+# and a shim to insert URL domains
+###
+namespace eval ::httpd::object {}
+namespace eval ::httpd::coro {}
+
+::tool::define ::httpd::server {
+ superclass ::httpd::mime
+
+ option port {default: auto}
+ option myaddr {default: 127.0.0.1}
+ option server_string [list default: [list TclHttpd $::httpd::version]]
+ option server_name [list default: [list [info hostname]]]
+ option doc_root {default {}}
+ option reverse_dns {type boolean default 0}
+ option configuration_file {type filename default {}}
+
+ property socket buffersize 32768
+ property socket translation {auto crlf}
+ property reply_class ::httpd::reply
+
+ array template
+ variable url_patterns {}
+
+ constructor {args} {
+ my configure {*}$args
+ my start
+ }
+
+ destructor {
+ my stop
+ }
+
+ method connect {sock ip port} {
+ ###
+ # If an IP address is blocked
+ # send a "go to hell" message
+ ###
+ if {[my Validate_Connection $sock $ip]} {
+ catch {close $sock}
+ return
+ }
+ set uuid [my Uuid_Generate]
+ set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
+ chan event $sock readable $coro
+ }
+
+ method Connect {uuid sock ip} {
+ yield [info coroutine]
+ chan event $sock readable {}
+
+ chan configure $sock \
+ -blocking 0 \
+ -translation {auto crlf} \
+ -buffering line
+
+ my counter url_hit
+ set line {}
+ try {
+ set readCount [::coroutine::util::gets_safety $sock 4096 line]
+ dict set query UUID $uuid
+ dict set query REMOTE_ADDR $ip
+ dict set query REMOTE_HOST [my HostName $ip]
+ dict set query REQUEST_METHOD [lindex $line 0]
+ set uriinfo [::uri::split [lindex $line 1]]
+ dict set query REQUEST_URI [lindex $line 1]
+ dict set query REQUEST_PATH [dict get $uriinfo path]
+ dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
+ dict set query DOCUMENT_ROOT [my cget doc_root]
+ dict set query QUERY_STRING [dict get $uriinfo query]
+ dict set query REQUEST_RAW $line
+ dict set query SERVER_PORT [my port_listening]
+ set mimetxt [my HttpHeaders $sock]
+ dict set query mimetxt $mimetxt
+ foreach {f v} [my MimeParse $mimetxt] {
+ set fld [string toupper [string map {- _} $f]]
+ if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
+ set qfld $fld
+ } else {
+ set qfld HTTP_$fld
+ }
+ dict set query $qfld $v
+ dict set query http $fld $v
+ }
+ if {[string match 127.* $ip]} {
+ dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
+ }
+ my Headers_Process query
+ set reply [my dispatch $query]
+ } on error {err errdat} {
+ my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
+ catch {chan close $sock}
+ return
+ }
+ if {[llength $reply]==0} {
+ my log BadLocation $uuid $query
+ my log BadLocation $uuid $query
+ dict set query HTTP_STATUS 404
+ dict set query template notfound
+ dict set query mixinmap reply ::httpd::content.template
+ }
+ try {
+ if {[dict exists $reply class]} {
+ set class [dict get $reply class]
+ } else {
+ set class [my cget reply_class]
+ }
+ set pageobj [$class create ::httpd::object::$uuid [self]]
+ if {[dict exists $reply mixinmap]} {
+ set mixinmap [dict get $reply mixinmap]
+ } else {
+ set mixinmap {}
+ }
+ if {[dict exists $reply mixin]} {
+ dict set mixinmap reply [dict get $reply mixin]
+ }
+ foreach item [dict keys $reply MIXIN_*] {
+ set slot [string range $reply 6 end]
+ dict set mixinmap [string tolower $slot] [dict get $reply $item]
+ }
+ $pageobj mixinmap {*}$mixinmap
+ if {[dict exists $reply organ]} {
+ $pageobj graft {*}[dict get $reply organ]
+ }
+ } on error {err errdat} {
+ my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ catch {$pageobj destroy}
+ catch {chan close $sock}
+ }
+ try {
+ $pageobj dispatch $sock $reply
+ } on error {err errdat} {
+ my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ catch {$pageobj destroy}
+ catch {chan close $sock}
+ }
+ }
+
+ method counter which {
+ my variable counters
+ incr counters($which)
+ }
+
+ ###
+ # Clean up any process that has gone out for lunch
+ ###
+ method CheckTimeout {} {
+ foreach obj [info commands ::httpd::object::*] {
+ try {
+ $obj timeOutCheck
+ } on error {} {
+ catch {$obj destroy}
+ }
+ }
+ }
+
+ method debug args {}
+
+ ###
+ # Route a request to the appropriate handler
+ ###
+ method dispatch {data} {
+ return [my Dispatch_Default $data]
+ }
+
+ method Dispatch_Default {reply} {
+ ###
+ # Fallback to docroot handling
+ ###
+ set doc_root [dict get $reply DOCUMENT_ROOT]
+ if {$doc_root ne {}} {
+ ###
+ # Fall back to doc_root handling
+ ###
+ dict set reply prefix {}
+ dict set reply path $doc_root
+ dict set reply mixinmap reply httpd::content.file
+ return $reply
+ }
+ return {}
+ }
+
+ method Headers_Process varname {}
+
+ method HostName ipaddr {
+ if {![my cget reverse_dns]} {
+ return $ipaddr
+ }
+ set t [::dns::resolve $ipaddr]
+ set result [::dns::name $t]
+ ::dns::cleanup $t
+ return $result
+ }
+
+ method log args {
+ # Do nothing for now
+ }
+
+ method plugin {slot {class {}}} {
+ if {$class eq {}} {
+ set class ::httpd::plugin.$slot
+ }
+ if {[info command $class] eq {}} {
+ error "Class $class for plugin $slot does not exist"
+ }
+ my mixinmap $slot $class
+ my variable mixinmap
+
+ ###
+ # Perform action on load
+ ###
+ eval [$class meta getnull plugin load:]
+
+ ###
+ # rebuild the dispatch method
+ ###
+ set body "\n try \{"
+ foreach {slot class} $mixinmap {
+ set script [$class meta getnull plugin dispatch:]
+ if {[string length $script]} {
+ append body \n "# SLOT $slot"
+ append body \n $script
+ }
+ }
+ append body \n { return [my Dispatch_Default $data]}
+ append body \n "\} on error \{err errdat\} \{"
+ append body \n { puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}}
+ append body \n "\}"
+ oo::objdefine [self] method dispatch data $body
+ ###
+ # rebuild the Headers_Process method
+ ###
+ set body "\n try \{"
+ append body \n " upvar 1 \$varname query"
+ foreach {slot class} $mixinmap {
+ set script [$class meta getnull plugin headers:]
+ if {[string length $script]} {
+ append body \n "# SLOT $slot"
+ append body \n $script
+ }
+ }
+ append body \n "\} on error \{err errdat\} \{"
+ append body \n { puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}}
+ append body \n "\}"
+ oo::objdefine [self] method Headers_Process varname $body
+
+ ###
+ # rebuild the Threads_Start method
+ ###
+ set body "\n try \{"
+ foreach {slot class} $mixinmap {
+ set script [$class meta getnull plugin thread:]
+ if {[string length $script]} {
+ append body \n "# SLOT $slot"
+ append body \n $script
+ }
+ }
+ append body \n "\} on error \{err errdat\} \{"
+ append body \n { puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}}
+ append body \n "\}"
+ oo::objdefine [self] method Thread_start {} $body
+
+ }
+
+ method port_listening {} {
+ my variable port_listening
+ return $port_listening
+ }
+
+ method PrefixNormalize prefix {
+ set prefix [string trimright $prefix /]
+ set prefix [string trimright $prefix *]
+ set prefix [string trimright $prefix /]
+ return $prefix
+ }
+
+ method source {filename} {
+ source $filename
+ }
+
+ method start {} {
+ # Build a namespace to contain replies
+ namespace eval [namespace current]::reply {}
+
+ my variable socklist port_listening
+ if {[my cget configuration_file] ne {}} {
+ source [my cget configuration_file]
+ }
+ set port [my cget port]
+ if { $port in {auto {}} } {
+ package require nettool
+ set port [::nettool::allocate_port 8015]
+ }
+ set port_listening $port
+ set myaddr [my cget myaddr]
+ my debug [list [self] listening on $port $myaddr]
+
+ if {$myaddr ni {all any * {}}} {
+ foreach ip $myaddr {
+ lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port]
+ }
+ } else {
+ lappend socklist [socket -server [namespace code [list my connect]] $port]
+ }
+ ::cron::every [self] 120 [namespace code {my CheckTimeout}]
+ my Thread_start
+ }
+
+ method stop {} {
+ my variable socklist
+ if {[info exists socklist]} {
+ foreach sock $socklist {
+ catch {close $sock}
+ }
+ }
+ set socklist {}
+ ::cron::cancel [self]
+ }
+
+
+ method template page {
+ my variable template
+ if {[info exists template($page)]} {
+ return $template($page)
+ }
+ set template($page) [my TemplateSearch $page]
+ return $template($page)
+ }
+
+ method TemplateSearch page {
+ set doc_root [my cget doc_root]
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
+ return [::fileutil::cat [file join $doc_root $page.tml]]
+ }
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
+ return [::fileutil::cat [file join $doc_root $page.html]]
+ }
+ switch $page {
+ redirect {
+return {
+[my html header "$HTTP_STATUS"]
+The page you are looking for: [my http_info get REQUEST_URI] has moved.
+
+If your browser does not automatically load the new location, it is
+$msg
+[my html footer]
+}
+ }
+ internal_error {
+ return {
+[my html header "$HTTP_STATUS"]
+Error serving [my http_info get REQUEST_URI] :
+
+The server encountered an internal server error:
$msg
+
+$errorInfo
+[my http_info get REQUEST_URI] does not exist.
+[my html footer]
+ }
+ }
+ }
+ }
+
+ method Thread_start {} {}
+
+ method Uuid_Generate {} {
+ return [::uuid::uuid generate]
+ }
+
+ ###
+ # Return true if this IP address is blocked
+ # The socket will be closed immediately after returning
+ # This handler is welcome to send a polite error message
+ ###
+ method Validate_Connection {sock ip} {
+ return 0
+ }
+}
+
+###
+# Provide a backward compadible alias
+###
+::tool::define ::httpd::server::dispatch {
+ superclass ::httpd::server
+}
ADDED modules/httpd/build/websocket.tcl
Index: modules/httpd/build/websocket.tcl
==================================================================
--- /dev/null
+++ modules/httpd/build/websocket.tcl
@@ -0,0 +1,6 @@
+###
+# Upgrade a connection to a websocket
+###
+::tool::define ::httpd::content.websocket {
+
+}
Index: modules/httpd/httpd.man
==================================================================
--- modules/httpd/httpd.man
+++ modules/httpd/httpd.man
@@ -51,13 +51,13 @@
}
::docserver::server create HTTPD port 8015 myaddr 127.0.0.1
HTTPD add_uri /* [list mixin reply.hello]
}]
-[include src/server.man]
-[include src/reply.man]
-[include src/content.man]
+[include build/server.man]
+[include build/reply.man]
+[include build/content.man]
[section AUTHORS]
Sean Woods
[vset CATEGORY network]
Index: modules/httpd/httpd.tcl
==================================================================
--- modules/httpd/httpd.tcl
+++ modules/httpd/httpd.tcl
@@ -2,13 +2,13 @@
# Amalgamated package for httpd
# Do not edit directly, tweak the source in src/ and rerun
# build.tcl
###
package require Tcl 8.6
-package provide httpd 4.1.1
+package provide httpd 4.2.0
namespace eval ::httpd {}
-set ::httpd::version 4.1.1
+set ::httpd::version 4.2.0
###
# START: core.tcl
###
###
@@ -22,30 +22,249 @@
# embedded another program, as well as be adapted and extended to
# support the SCGI module
###
package require uri
+package require dns
package require cron
package require coroutine
package require tool
package require mime
package require fileutil
package require websocket
-###
-# Standard library of HTTP/SCGI content
-# Each of these classes are intended to be mixed into
-# either an HTTPD or SCGI reply
-###
package require Markdown
+package require uuid
package require fileutil::magic::filetype
+
namespace eval httpd::content {}
namespace eval ::url {}
namespace eval ::httpd {}
namespace eval ::scgi {}
+tool::define ::httpd::mime {
+
+ method html_header {{title {}} args} {
+ set result {}
+ append result ""
+ if {$title ne {}} {
+ append result "$title "
+ }
+ append result " $ServerObj
foreach {field value} [::oo::meta::args_to_options {*}$args] {
my meta set config $field: $value
}
}
@@ -91,78 +296,88 @@
}
method close {} {
my variable chan
if {[info exists chan] && $chan ne {}} {
- catch {flush $chan}
- catch {close $chan}
- }
- }
-
- method HttpHeaders {sock {debug {}}} {
- set result {}
- ###
- # Set up a channel event to stream the data from the socket line by
- # line. When a blank line is read, the HttpHeaderLine method will send
- # a flag which will terminate the vwait.
- #
- # We do this rather than entering blocking mode to prevent the process
- # from locking up if it's starved for input. (Or in the case of the test
- # suite, when we are opening a blocking channel on the other side of the
- # socket back to ourselves.)
- ###
- chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
- try {
- while 1 {
- set readCount [::coroutine::util::gets_safety $sock 4096 line]
- if {$readCount==0} break
- append result $line \n
- }
- } trap {POSIX EBUSY} {err info} {
- # Happens...
- } on error {err info} {
- puts "ERROR $err"
- puts [dict print $info]
- tailcall my destroy
- }
- ###
- # Return our buffer
- ###
- return $result
- }
-
- method HttpHeaders_Default {} {
- return {Status {200 OK}
-Content-Size 0
-Content-Type {text/html; charset=UTF-8}
-Cache-Control {no-cache}
-Connection close}
+ catch {chan event $chan readable {}}
+ catch {chan event $chan writable {}}
+ catch {chan flush $chan}
+ catch {chan close $chan}
+ set chan {}
+ }
+ }
+
+ method Log_Dispatched {} {
+ my log Dispatched [dict create \
+ REMOTE_ADDR [my http_info get REMOTE_ADDR] \
+ REMOTE_HOST [my http_info get REMOTE_HOST] \
+ COOKIE [my request get COOKIE] \
+ REFERER [my request get REFERER] \
+ USER_AGENT [my request get USER_AGENT] \
+ REQUEST_URI [my http_info get REQUEST_URI] \
+ HTTP_HOST [my http_info getnull HTTP_HOST] \
+ SESSION [my http_info getnull SESSION] \
+ ]
}
method dispatch {newsock datastate} {
my http_info replace $datastate
- my variable chan rawrequest dipatched_time
+ my request replace [dict getnull $datastate http]
+ my Log_Dispatched
+ my variable chan
set chan $newsock
- chan event $chan readable {}
- chan configure $chan -translation {auto crlf} -buffering line
- set dispatched_time [clock seconds]
try {
- # Initialize the reply
+ chan event $chan readable {}
+ chan configure $chan -translation {auto crlf} -buffering line
my reset
- # Process the incoming MIME headers
- set rawrequest [my HttpHeaders $chan]
- my request parse $rawrequest
# Invoke the URL implementation.
my content
- } on error {err info} {
- #dict print $info
- #puts stderr $::errorInfo
- my error 500 $err [dict get $info -errorinfo]
+ } on error {err errdat} {
+ my error 500 $err [dict get $errdat -errorinfo]
} finally {
- my output
+ my DoOutput
}
}
+
+ method html_css {} {
+ set result "$title "
+ }
+ append result [my html_css]
+ append result ""
+ append result \n {}
+ if {[dict exists $args sideimg]} {
+ append result "\n"
+ }
+ append result {}
+ return $result
+ }
+
+ method html_footer {args} {
+ set result {
}
+ }
dictobj http_info http_info {
initialize {
CONTENT_LENGTH 0
}
@@ -176,48 +391,30 @@
}
method error {code {msg {}} {errorInfo {}}} {
my http_info set HTTP_ERROR $code
my reset
- my variable error_codes
set qheaders [my http_info dump]
- if {![info exists error_codes($code)]} {
- set errorstring "Unknown Error Code"
- } else {
- set errorstring $error_codes($code)
- }
+ set HTTP_STATUS "$code [my http_code_string $code]"
dict with qheaders {}
my reply replace {}
- my reply set Status "$code $errorstring"
+ my reply set Status $HTTP_STATUS
my reply set Content-Type {text/html; charset=UTF-8}
- my puts "
-
-
-$code $errorstring
-
-"
- if {$msg eq {}} {
- my puts "
-Got the error $code $errorstring
-
-while trying to obtain $REQUEST_URI
- "
- } else {
- my puts "
-Guru meditation #[clock seconds]
-
-The server encountered an internal error:
-
-
$msg
-
-For deeper understanding:
-
-
$errorInfo
-"
- }
- my puts "
-"
+
+ switch $code {
+ 301 - 302 - 303 - 307 - 308 {
+ my reply set Location $msg
+ set template [my template redirect]
+ }
+ 404 {
+ set template [my template notfound]
+ }
+ default {
+ set template [my template internal_error]
+ }
+ }
+ my puts [subst $template]
}
###
# REPLACE ME:
@@ -224,34 +421,39 @@
# This method is the "meat" of your application.
# It writes to the result buffer via the "puts" method
# and can tweak the headers via "meta put header_reply"
###
method content {} {
- my puts ""
- my puts ""
+ my puts [my html_header {Hello World!}]
my puts "HELLO WORLD! "
- my puts ""
- my puts ""
+ my puts [my html_footer]
}
method EncodeStatus {status} {
return "HTTP/1.0 $status"
}
- method output {} {
- my variable chan
- chan event $chan writable [namespace code {my DoOutput}]
+ method log {type {info {}}} {
+ my variable dispatched_time uuid
+ my log $type $uuid $info
+ }
+
+ method CoroName {} {
+ if {[info coroutine] eq {}} {
+ return ::httpd::object::[my http_info get UUID]
+ }
}
###
# Output the result or error to the channel
# and destroy this object
###
method DoOutput {} {
my variable reply_body chan
- chan event $chan writable {}
+ if {$chan eq {}} return
catch {
+ my wait writable $chan
chan configure $chan -translation {binary binary}
###
# Return dynamic content
###
set length [string length $reply_body]
@@ -262,36 +464,29 @@
append result $reply_body
} else {
append result [my reply output]
}
chan puts -nonewline $chan $result
- } err
- puts $err
+ my log HttpAccess {}
+ }
my destroy
}
- method Url_Decode 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]
- }
-
method FormData {} {
- my variable chan formdata rawrequest
+ my variable chan formdata
# Run this only once
if {[info exists formdata]} {
return $formdata
}
- if {![my request exists Content-Length]} {
+ if {![my request exists CONTENT_LENGTH]} {
set length 0
} else {
- set length [my request get Content-Length]
+ set length [my request get CONTENT_LENGTH]
}
set formdata {}
if {[my http_info get REQUEST_METHOD] in {"POST" "PUSH"}} {
- set rawtype [my request get Content-Type]
+ set rawtype [my request get CONTENT_TYPE]
if {[string toupper [string range $rawtype 0 8]] ne "MULTIPART"} {
set type $rawtype
} else {
set type multipart
}
@@ -298,11 +493,11 @@
switch $type {
multipart {
###
# Ok, Multipart MIME is troublesome, farm out the parsing to a dedicated tool
###
- set body $rawrequest
+ set body [my http_info get mimetxt]
append body \n [my PostData $length]
set token [::mime::initialize -string $body]
foreach item [::mime::getheader $token -names] {
dict set formdata $item [::mime::getheader $token $item]
}
@@ -331,90 +526,10 @@
}
}
return $formdata
}
- ###
- # Minimalist MIME Header Parser
- ###
- method MimeParse mimetext {
- set data(mimeorder) {}
- foreach line [split $mimetext \n] {
- # This regexp picks up
- # key: value
- # MIME headers. MIME headers may be continue with a line
- # that starts with spaces or a tab
- if {[string length [string trim $line]]==0} break
- if {[regexp {^([^ :]+):[ ]*(.*)} $line dummy key value]} {
- # The following allows something to
- # recreate the headers exactly
- lappend data(headerlist) $key $value
- # The rest of this makes it easier to pick out
- # headers from the data(mime,headername) array
- #set key [string tolower $key]
- if {[info exists data(mime,$key)]} {
- append data(mime,$key) ,$value
- } else {
- set data(mime,$key) $value
- lappend data(mimeorder) $key
- }
- set data(key) $key
- } elseif {[regexp {^[ ]+(.*)} $line dummy value]} {
- # Are there really continuation lines in the spec?
- if {[info exists data(key)]} {
- append data(mime,$data(key)) " " $value
- } else {
- my error 400 "INVALID HTTP HEADER FORMAT: $line"
- tailcall my output
- }
- } else {
- my error 400 "INVALID HTTP HEADER FORMAT: $line"
- tailcall my output
- }
- }
- ###
- # To make life easier for our SCGI implementation rig things
- # such that CONTENT_LENGTH is always first
- # Also map all headers specified in rfc2616 to their canonical case
- ###
- set result {}
- dict set result Content-Length 0
- foreach {key} $data(mimeorder) {
- switch [string tolower $key] {
- content-length {
- set key Content-Length
- }
- content-encoding {
- set key Content-Encoding
- }
- content-language {
- set key Content-Language
- }
- content-location {
- set key Content-Location
- }
- content-md5 {
- set key Content-MD5
- }
- content-range {
- set key Content-Range
- }
- content-type {
- set key Content-Type
- }
- expires {
- set key Expires
- }
- last-modified {
- set key Last-Modified
- }
- }
- dict set result $key $data(mime,$key)
- }
- return $result
- }
-
method PostData {length} {
my variable postdata
# Run this only once
if {[info exists postdata]} {
return $postdata
@@ -427,12 +542,19 @@
}
return $postdata
}
method TransferComplete args {
+ my variable chan transfer_complete
+ set transfer_complete 1
+ my log TransferComplete
+ set chan {}
foreach c $args {
- catch {close $c}
+ catch {chan event $c readable {}}
+ catch {chan event $c writable {}}
+ catch {chan flush $c}
+ catch {chan close $c}
}
my destroy
}
###
@@ -446,11 +568,11 @@
method RequestFind {field} {
my variable request
if {[dict exists $request $field]} {
return $field
}
- foreach item [dict gets $request] {
+ foreach item [dict keys $request] {
if {[string tolower $item] eq [string tolower $field]} {
return $item
}
}
return $field
@@ -478,11 +600,15 @@
exists {
set field [my RequestFind [lindex $args 0]]
tailcall dict exists $request $field
}
parse {
- set request [my MimeParse [lindex $args 0]]
+ if {[catch {my MimeParse [lindex $args 0]} result]} {
+ my error 400 $result
+ tailcall my DoOutput
+ }
+ set request $result
}
}
dictobj reply reply {
output {
@@ -516,17 +642,19 @@
###
# Return true of this class as waited too long to respond
###
method timeOutCheck {} {
- my variable dipatched_time
- if {([clock seconds]-$dipatched_time)>30} {
+ my variable dispatched_time
+ if {([clock seconds]-$dispatched_time)>120} {
###
# Something has lasted over 2 minutes. Kill this
###
- my error 505 {Operation Timed out}
- my output
+ catch {
+ my error 408 {Request Timed out}
+ my DoOutput
+ }
}
}
###
# Return a timestamp
@@ -544,18 +672,23 @@
###
###
# An httpd server with a template engine
# and a shim to insert URL domains
###
+namespace eval ::httpd::object {}
+namespace eval ::httpd::coro {}
::tool::define ::httpd::server {
+ superclass ::httpd::mime
option port {default: auto}
option myaddr {default: 127.0.0.1}
option server_string [list default: [list TclHttpd $::httpd::version]]
option server_name [list default: [list [info hostname]]]
option doc_root {default {}}
+ option reverse_dns {type boolean default 0}
+ option configuration_file {type filename default {}}
property socket buffersize 32768
property socket translation {auto crlf}
property reply_class ::httpd::reply
@@ -569,15 +702,10 @@
destructor {
my stop
}
- method add_uri {pattern info} {
- my variable url_patterns
- dict set url_patterns $pattern $info
- }
-
method connect {sock ip port} {
###
# If an IP address is blocked
# send a "go to hell" message
###
@@ -584,11 +712,11 @@
if {[my Validate_Connection $sock $ip]} {
catch {close $sock}
return
}
set uuid [my Uuid_Generate]
- set coro [coroutine [namespace current]::CORO$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
+ set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
chan event $sock readable $coro
}
method Connect {uuid sock ip} {
yield [info coroutine]
@@ -601,81 +729,89 @@
my counter url_hit
set line {}
try {
set readCount [::coroutine::util::gets_safety $sock 4096 line]
+ dict set query UUID $uuid
dict set query REMOTE_ADDR $ip
+ dict set query REMOTE_HOST [my HostName $ip]
dict set query REQUEST_METHOD [lindex $line 0]
set uriinfo [::uri::split [lindex $line 1]]
dict set query REQUEST_URI [lindex $line 1]
dict set query REQUEST_PATH [dict get $uriinfo path]
dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
- if {[dict get $uriinfo host] eq {}} {
- if {$ip eq "127.0.0.1"} {
- dict set query HTTP_HOST localhost
- } else {
- dict set query HTTP_HOST [info hostname]
- }
- } else {
- dict set query HTTP_HOST [dict get $uriinfo host]
- }
- dict set query HTTP_CLIENT_IP $ip
+ dict set query DOCUMENT_ROOT [my cget doc_root]
dict set query QUERY_STRING [dict get $uriinfo query]
dict set query REQUEST_RAW $line
+ dict set query SERVER_PORT [my port_listening]
+ set mimetxt [my HttpHeaders $sock]
+ dict set query mimetxt $mimetxt
+ foreach {f v} [my MimeParse $mimetxt] {
+ set fld [string toupper [string map {- _} $f]]
+ if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
+ set qfld $fld
+ } else {
+ set qfld HTTP_$fld
+ }
+ dict set query $qfld $v
+ dict set query http $fld $v
+ }
+ if {[string match 127.* $ip]} {
+ dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
+ }
+ my Headers_Process query
+ set reply [my dispatch $query]
} on error {err errdat} {
- puts stderr $err
- my log HttpError $line
- catch {close $sock}
+ my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
+ catch {chan close $sock}
return
}
- try {
- set reply [my dispatch $query]
- if {[llength $reply]} {
- if {[dict exists $reply class]} {
- set class [dict get $reply class]
- } else {
- set class [my cget reply_class]
- }
- set pageobj [$class create [namespace current]::reply$uuid [self]]
- if {[dict exists $reply mixin]} {
- oo::objdefine $pageobj mixin [dict get $reply mixin]
- }
- $pageobj dispatch $sock $reply
- my log HttpAccess $line
- } else {
- try {
- my log HttpMissing $line
- chan puts $sock "HTTP/1.0 404 NOT FOUND"
- dict with query {}
- set body [subst [my template notfound]]
- chan puts $sock "Content-Length: [string length $body]"
- chan puts $sock {}
- chan puts $sock $body
- } on error {err errdat} {
- puts stderr "FAILED ON 404: $err"
- } finally {
- catch {chan close $sock}
- catch {destroy $pageobj}
- }
- }
- } on error {err errdat} {
- try {
- #puts stderr [dict print $errdat]
- chan puts $sock "HTTP/1.0 505 INTERNAL ERROR - server 119"
- dict with query {}
- set body [subst [my template internal_error]]
- chan puts $sock "Content-Length: [string length $body]"
- chan puts $sock {}
- chan puts $sock $body
- my log HttpError $line
- } on error {err errdat} {
- my log HttpFatal $::errorInfo
- #puts stderr "FAILED ON 505: $::errorInfo"
- } finally {
- catch {chan close $sock}
- catch {destroy $pageobj}
- }
+ if {[llength $reply]==0} {
+ my log BadLocation $uuid $query
+ my log BadLocation $uuid $query
+ dict set query HTTP_STATUS 404
+ dict set query template notfound
+ dict set query mixinmap reply ::httpd::content.template
+ }
+ try {
+ if {[dict exists $reply class]} {
+ set class [dict get $reply class]
+ } else {
+ set class [my cget reply_class]
+ }
+ set pageobj [$class create ::httpd::object::$uuid [self]]
+ if {[dict exists $reply mixinmap]} {
+ set mixinmap [dict get $reply mixinmap]
+ } else {
+ set mixinmap {}
+ }
+ if {[dict exists $reply mixin]} {
+ dict set mixinmap reply [dict get $reply mixin]
+ }
+ foreach item [dict keys $reply MIXIN_*] {
+ set slot [string range $reply 6 end]
+ dict set mixinmap [string tolower $slot] [dict get $reply $item]
+ }
+ $pageobj mixinmap {*}$mixinmap
+ if {[dict exists $reply organ]} {
+ $pageobj graft {*}[dict get $reply organ]
+ }
+ } on error {err errdat} {
+ my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ catch {$pageobj destroy}
+ catch {chan close $sock}
+ }
+ try {
+ $pageobj dispatch $sock $reply
+ } on error {err errdat} {
+ my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
+ catch {$pageobj destroy}
+ catch {chan close $sock}
}
}
method counter which {
my variable counters
@@ -684,51 +820,125 @@
###
# Clean up any process that has gone out for lunch
###
method CheckTimeout {} {
- foreach obj [info commands [namespace current]::reply::*] {
+ foreach obj [info commands ::httpd::object::*] {
try {
$obj timeOutCheck
} on error {} {
catch {$obj destroy}
}
}
}
+ method debug args {}
+
###
# Route a request to the appropriate handler
###
method dispatch {data} {
- set reply $data
- set uri [dict get $data REQUEST_PATH]
- # Search from longest pattern to shortest
- my variable url_patterns
- foreach {pattern info} $url_patterns {
- if {[string match ${pattern} /$uri]} {
- set reply [dict merge $data $info]
- if {![dict exists $reply prefix]} {
- dict set reply prefix [my PrefixNormalize $pattern]
- }
- return $reply
- }
- }
- set doc_root [my cget doc_root]
+ return [my Dispatch_Default $data]
+ }
+
+ method Dispatch_Default {reply} {
+ ###
+ # Fallback to docroot handling
+ ###
+ set doc_root [dict get $reply DOCUMENT_ROOT]
if {$doc_root ne {}} {
###
# Fall back to doc_root handling
###
dict set reply prefix {}
dict set reply path $doc_root
- dict set reply mixin httpd::content.file
+ dict set reply mixinmap reply httpd::content.file
return $reply
}
return {}
}
+
+ method Headers_Process varname {}
+
+ method HostName ipaddr {
+ if {![my cget reverse_dns]} {
+ return $ipaddr
+ }
+ set t [::dns::resolve $ipaddr]
+ set result [::dns::name $t]
+ ::dns::cleanup $t
+ return $result
+ }
method log args {
# Do nothing for now
+ }
+
+ method plugin {slot {class {}}} {
+ if {$class eq {}} {
+ set class ::httpd::plugin.$slot
+ }
+ if {[info command $class] eq {}} {
+ error "Class $class for plugin $slot does not exist"
+ }
+ my mixinmap $slot $class
+ my variable mixinmap
+
+ ###
+ # Perform action on load
+ ###
+ eval [$class meta getnull plugin load:]
+
+ ###
+ # rebuild the dispatch method
+ ###
+ set body "\n try \{"
+ foreach {slot class} $mixinmap {
+ set script [$class meta getnull plugin dispatch:]
+ if {[string length $script]} {
+ append body \n "# SLOT $slot"
+ append body \n $script
+ }
+ }
+ append body \n { return [my Dispatch_Default $data]}
+ append body \n "\} on error \{err errdat\} \{"
+ append body \n { puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}}
+ append body \n "\}"
+ oo::objdefine [self] method dispatch data $body
+ ###
+ # rebuild the Headers_Process method
+ ###
+ set body "\n try \{"
+ append body \n " upvar 1 \$varname query"
+ foreach {slot class} $mixinmap {
+ set script [$class meta getnull plugin headers:]
+ if {[string length $script]} {
+ append body \n "# SLOT $slot"
+ append body \n $script
+ }
+ }
+ append body \n "\} on error \{err errdat\} \{"
+ append body \n { puts [list HEADERS ERROR [dict get $errdat -errorinfo]] ; return {}}
+ append body \n "\}"
+ oo::objdefine [self] method Headers_Process varname $body
+
+ ###
+ # rebuild the Threads_Start method
+ ###
+ set body "\n try \{"
+ foreach {slot class} $mixinmap {
+ set script [$class meta getnull plugin thread:]
+ if {[string length $script]} {
+ append body \n "# SLOT $slot"
+ append body \n $script
+ }
+ }
+ append body \n "\} on error \{err errdat\} \{"
+ append body \n { puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}}
+ append body \n "\}"
+ oo::objdefine [self] method Thread_start {} $body
+
}
method port_listening {} {
my variable port_listening
return $port_listening
@@ -738,33 +948,41 @@
set prefix [string trimright $prefix /]
set prefix [string trimright $prefix *]
set prefix [string trimright $prefix /]
return $prefix
}
+
+ method source {filename} {
+ source $filename
+ }
method start {} {
# Build a namespace to contain replies
namespace eval [namespace current]::reply {}
my variable socklist port_listening
+ if {[my cget configuration_file] ne {}} {
+ source [my cget configuration_file]
+ }
set port [my cget port]
if { $port in {auto {}} } {
package require nettool
set port [::nettool::allocate_port 8015]
}
set port_listening $port
set myaddr [my cget myaddr]
- my log [list [self] listening on $port $myaddr]
+ my debug [list [self] listening on $port $myaddr]
if {$myaddr ni {all any * {}}} {
foreach ip $myaddr {
lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port]
}
} else {
lappend socklist [socket -server [namespace code [list my connect]] $port]
}
::cron::every [self] 120 [namespace code {my CheckTimeout}]
+ my Thread_start
}
method stop {} {
my variable socklist
if {[info exists socklist]} {
@@ -793,41 +1011,46 @@
}
if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
return [::fileutil::cat [file join $doc_root $page.html]]
}
switch $page {
+ redirect {
+return {
+[my html header "$HTTP_STATUS"]
+The page you are looking for: [my http_info get REQUEST_URI] has moved.
+
+If your browser does not automatically load the new location, it is
+$msg
+[my html footer]
+}
+ }
internal_error {
return {
-
-
505: Internal Server Error
-
-Error serving ${REQUEST_URI} :
+[my html header "$HTTP_STATUS"]
+Error serving [my http_info get REQUEST_URI] :
-The server encountered an internal server error
+The server encountered an internal server error:
$msg
-$::errorInfo
+$errorInfo
404: Page Not Found
-
-The page you are looking for: ${REQUEST_URI} does not exist.
-
-
+[my html header "$HTTP_STATUS"]
+The page you are looking for: [my http_info get REQUEST_URI] does not exist.
+[my html footer]
}
}
}
}
+
+ method Thread_start {} {}
method Uuid_Generate {} {
- my variable next_uuid
- return [incr next_uuid]
+ return [::uuid::uuid generate]
}
###
# Return true if this IP address is blocked
# The socket will be closed immediately after returning
@@ -849,18 +1072,74 @@
# END: server.tcl
###
###
# START: dispatch.tcl
###
+::tool::define ::httpd::content.redirect {
+
+ method reset {} {
+ ###
+ # Inject the location into the HTTP headers
+ ###
+ my variable reply_body
+ set reply_body {}
+ my reply replace [my HttpHeaders_Default]
+ my reply set Server [my cget server_string]
+ set msg [my http_info get LOCATION]
+ my reply set Location [my http_info get LOCATION]
+ set code [my http_info getnull REDIRECT_CODE]
+ if {$code eq {}} {
+ set code 301
+ }
+ my reply set Status [list $code [my http_code_string $code]]
+ }
+
+ method content {} {
+ set template [my template redirect]
+ set msg [my http_info get LOCATION]
+ set HTTP_STATUS [my reply get Status]
+ my puts [subst $msg]
+ }
+}
+
+::tool::define ::httpd::content.cache {
+
+ method dispatch {newsock datastate} {
+ my http_info replace $datastate
+ my request replace [dict get $datastate http]
+ my variable chan
+ set chan $newsock
+ chan event $chan readable {}
+ try {
+ my Log_Dispatched
+ my wait writable $chan
+ chan configure $chan -translation {binary binary}
+ chan puts -nonewline $chan [my http_info get CACHE_DATA]
+ } on error {err info} {
+ my debug [dict get $info -errorinfo]
+ } finally {
+ my TransferComplete $chan
+ }
+ }
+}
+
+::tool::define ::httpd::content.template {
+
+ method content {} {
+ if {[my http_info getnull HTTP_STATUS] ne {}} {
+ my reply set Status [my http_info getnull HTTP_STATUS]
+ }
+ my puts [subst [my template [my http_info get template]]]
+ }
+}
###
# END: dispatch.tcl
###
###
# START: file.tcl
###
-
###
# Class to deliver Static content
# When utilized, this class is fed a local filename
# by the dispatcher
###
@@ -887,20 +1166,16 @@
return [file join $path $fname.tml]
}
return {}
}
-
method DirectoryListing {local_file} {
set uri [string trimleft [my http_info get REQUEST_URI] /]
set path [my http_info get path]
set prefix [my http_info get prefix]
set fname [string range $uri [string length $prefix] end]
- my puts "Listing of /$fname/ "
- my puts "Path: $path"
if {$prefix ni {/ {}}} {
set updir [file dirname $prefix]
if {$updir ne {}} {
@@ -912,43 +1187,32 @@
my puts "[file tail $file]/ [file tail $file] [file size $file]
"
- }
-
- method dispatch {newsock datastate} {
- # No need to process the rest of the headers
- my variable chan dipatched_time
- set dispatched_time [clock seconds]
- my http_info replace $datastate
- set chan $newsock
- my content
- my output
+ my puts ""
+ my puts [my html_footer]
}
method content {} {
- ###
- # When delivering static content, allow web caches to save
- ###
- my reply set Cache-Control {max-age=3600}
my variable reply_file
set local_file [my FileName]
if {$local_file eq {} || ![file exist $local_file]} {
- my log httpNotFound [my http_info get REQUEST_URI]
- tailcall my error 404 {Not Found}
+ my log httpNotFound [my http_info get REQUEST_URI]
+ my error 404 {File Not Found}
+ tailcall my DoOutput
}
- if {[file isdirectory $local_file]} {
+ if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
###
# Produce an index page
###
set idxfound 0
foreach name {
index.html
index.tml
index.md
+ content.htm
} {
if {[file exists [file join $local_file $name]]} {
set idxfound 1
set local_file [file join $local_file $name]
break
@@ -980,59 +1244,426 @@
set reply_file $local_file
}
}
}
- ###
- # Output the result or error to the channel
- # and destroy this object
- ###
- method DoOutput {} {
- my variable chan
- chan event $chan writable {}
+ method dispatch {newsock datastate} {
my variable reply_body reply_file reply_chan chan
- chan configure $chan -translation {binary binary}
+ try {
+ my http_info replace $datastate
+ my request replace [dict get $datastate http]
+ my Log_Dispatched
+ set chan $newsock
+ chan event $chan readable {}
+ chan configure $chan -translation {auto crlf} -buffering line
+
+ my reset
+ # Invoke the URL implementation.
+ my content
+ } on error {err errdat} {
+ my error 500 $err [dict get $errdat -errorinfo]
+ tailcall my DoOutput
+ }
+ if {$chan eq {}} return
+ my wait writable $chan
if {![info exists reply_file]} {
- ###
- # Return dynamic content
- ###
- if {![info exists reply_body]} {
- append result [my reply output]
- } else {
- set reply_body [string trim $reply_body]
- my reply set Content-Length [string length $reply_body]
- append result [my reply output] \n
- append result $reply_body
- chan puts -nonewline $chan $result
- chan flush $chan
- }
- my destroy
- } else {
+ tailcall my DoOutput
+ }
+ try {
+ chan configure $chan -translation {binary binary}
+ my log HttpAccess {}
###
# Return a stream of data from a file
###
set size [file size $reply_file]
my reply set Content-Length $size
append result [my reply output] \n
chan puts -nonewline $chan $result
set reply_chan [open $reply_file r]
+ my log SendReply [list length $size]
chan configure $reply_chan -translation {binary binary}
- chan copy $reply_chan $chan -command [namespace code [list my TransferComplete $reply_chan]]
+ ###
+ # Send any POST/PUT/etc content
+ # Note, we are terminating the coroutine at this point
+ # and using the file event to wake the object back up
+ #
+ # We *could*:
+ # chan copy $sock $chan -command [info coroutine]
+ # yield
+ #
+ # But in the field this pegs the CPU for long transfers and locks
+ # up the process
+ ###
+ chan copy $reply_chan $chan -command [namespace code [list my TransferComplete $reply_chan $chan]]
+ } on error {err errdat} {
+ my TransferComplete $reply_chan $chan
}
}
}
###
# END: file.tcl
###
+###
+# START: proxy.tcl
+###
+::tool::define ::httpd::content.exec {
+ variable exename [list tcl [info nameofexecutable] .tcl [info nameofexecutable]]
+
+ method CgiExec {execname script arglist} {
+ if { $::tcl_platform(platform) eq "windows"} {
+ if {[file extension $script] eq ".exe"} {
+ return [open "|[list $script] $arglist" r+]
+ } else {
+ if {$execname eq {}} {
+ set execname [my Cgi_Executable $script]
+ }
+ return [open "|[list $execname $script] $arglist" r+]
+ }
+ } else {
+ if {$execname eq {}} {
+ return [open "|[list $script] $arglist 2>@1" r+]
+ } else {
+ return [open "|[list $execname $script] $arglist 2>@1" r+]
+ }
+ }
+ error "CGI Not supported"
+ }
+
+ method Cgi_Executable {script} {
+ if {[string tolower [file extension $script]] eq ".exe"} {
+ return $script
+ }
+ my variable exename
+ set ext [file extension $script]
+ if {$ext eq {}} {
+ set which [file tail $script]
+ } else {
+ if {[dict exists exename $ext]} {
+ return [dict get $exename $ext]
+ }
+ switch $ext {
+ .pl {
+ set which perl
+ }
+ .py {
+ set which python
+ }
+ .php {
+ set which php
+ }
+ .fossil - .fos {
+ set which fossil
+ }
+ default {
+ set which tcl
+ }
+ }
+ if {[dict exists exename $which]} {
+ set result [dict get $exename $which]
+ dict set exename $ext $result
+ return $result
+ }
+ }
+ if {[dict exists exename $which]} {
+ return [dict get $exename $which]
+ }
+ if {$which eq "tcl"} {
+ if {[my cget tcl_exe] ne {}} {
+ dict set exename $which [my cget tcl_exe]
+ } else {
+ dict set exename $which [info nameofexecutable]
+ }
+ } else {
+ if {[my cget ${which}_exe] ne {}} {
+ dict set exename $which [my cget ${which}_exe]
+ } elseif {"$::tcl_platform(platform)" == "windows"} {
+ dict set exename $which $which.exe
+ } else {
+ dict set exename $which $which
+ }
+ }
+ set result [dict get $exename $which]
+ if {$ext ne {}} {
+ dict set exename $ext $result
+ }
+ return $result
+ }
+}
+
+###
+# Return data from an proxy process
+###
+::tool::define ::httpd::content.proxy {
+ superclass ::httpd::content.exec
+
+ method proxy_channel {} {
+ ###
+ # This method returns a channel to the
+ # proxied socket/stdout/etc
+ ###
+ error unimplemented
+ }
+
+ method proxy_path {} {
+ set uri [string trimleft [my http_info get REQUEST_URI] /]
+ set prefix [my http_info get prefix]
+ return /[string range $uri [string length $prefix] end]
+ }
+
+ method ProxyRequest {chana chanb} {
+ chan event $chanb writable {}
+ my log ProxyRequest {}
+ chan puts $chanb "[my http_info get REQUEST_METHOD] [my proxy_path]"
+ chan puts $chanb [my http_info get mimetxt]
+ set length [my http_info get CONTENT_LENGTH]
+ if {$length} {
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
+ ###
+ # Send any POST/PUT/etc content
+ ###
+ chan copy $chana $chanb -size $length -command [info coroutine]
+ } else {
+ chan flush $chanb
+ chan event $chanb readable [info coroutine]
+ }
+ yield
+ }
+
+ method ProxyReply {chana chanb args} {
+ my log ProxyReply [list args $args]
+ chan event $chana readable {}
+ set readCount [::coroutine::util::gets_safety $chana 4096 reply_status]
+ set replyhead [my HttpHeaders $chana]
+ set replydat [my MimeParse $replyhead]
+ if {![dict exists $replydat Content-Length]} {
+ set length 0
+ } else {
+ set length [dict get $replydat Content-Length]
+ }
+ ###
+ # Read the first incoming line as the HTTP reply status
+ # Return the rest of the headers verbatim
+ ###
+ set replybuffer "$reply_status\n"
+ append replybuffer $replyhead
+ chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
+ chan puts $chanb $replybuffer
+ my log SendReply [list length $length]
+ if {$length} {
+ ###
+ # Output the body
+ ###
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan copy $chana $chanb -size $length -command [namespace code [list my TransferComplete $chana $chanb]]
+ } else {
+ my TransferComplete $chana $chanb
+ }
+ }
+
+ method dispatch {newsock datastate} {
+ try {
+ my http_info replace $datastate
+ my request replace [dict get $datastate http]
+ my Log_Dispatched
+ my variable sock chan
+ set chan $newsock
+ chan configure $chan -translation {auto crlf} -buffering line
+ # Initialize the reply
+ my reset
+ # Invoke the URL implementation.
+ } on error {err errdat} {
+ my error 500 $err [dict get $errdat -errorinfo]
+ tailcall my DoOutput
+ }
+ if {[catch {my proxy_channel} sock errdat]} {
+ my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo]
+ tailcall my DoOutput
+ }
+ if {$sock eq {}} {
+ my error 404 {Not Found}
+ tailcall my DoOutput
+ }
+ my log HttpAccess {}
+ chan event $sock writable [info coroutine]
+ yield
+ my ProxyRequest $chan $sock
+ my ProxyReply $sock $chan
+ }
+}
+
+###
+# END: proxy.tcl
+###
+###
+# START: cgi.tcl
+###
+::tool::define ::httpd::content.cgi {
+ superclass ::httpd::content.proxy
+
+ method FileName {} {
+ set uri [string trimleft [my http_info get REQUEST_URI] /]
+ set path [my http_info get path]
+ set prefix [my http_info get prefix]
+
+ set fname [string range $uri [string length $prefix] end]
+ if {[file exists [file join $path $fname]]} {
+ return [file join $path $fname]
+ }
+ if {[file exists [file join $path $fname.fossil]]} {
+ return [file join $path $fname.fossil]
+ }
+ if {[file exists [file join $path $fname.fos]]} {
+ return [file join $path $fname.fos]
+ }
+ if {[file extension $fname] in {.exe .cgi .tcl .pl .py .php}} {
+ return $fname
+ }
+ return {}
+ }
+
+ method proxy_channel {} {
+ ###
+ # When delivering static content, allow web caches to save
+ ###
+ set local_file [my FileName]
+ if {$local_file eq {} || ![file exist $local_file]} {
+ my log httpNotFound [my http_info get REQUEST_URI]
+ my error 404 {Not Found}
+ tailcall my DoOutput
+ }
+ if {[file isdirectory $local_file]} {
+ ###
+ # Produce an index page... or error
+ ###
+ tailcall my DirectoryListing $local_file
+ }
+
+ set verbatim {
+ CONTENT_LENGTH CONTENT_TYPE QUERY_STRING REMOTE_USER AUTH_TYPE
+ REQUEST_METHOD REMOTE_ADDR REMOTE_HOST REQUEST_URI REQUEST_PATH
+ REQUEST_VERSION DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
+ GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
+ SERVER_NAME SERVER_SOFTWARE SERVER_PROTOCOL
+ }
+ foreach item $verbatim {
+ set ::env($item) {}
+ }
+ foreach item [array names ::env HTTP_*] {
+ set ::env($item) {}
+ }
+ set ::env(SCRIPT_NAME) [my http_info get REQUEST_PATH]
+ set ::env(SERVER_PROTOCOL) HTTP/1.0
+ set ::env(HOME) $::env(DOCUMENT_ROOT)
+ foreach {f v} [my http_info dump] {
+ if {$f in $verbatim} {
+ set ::env($f) $v
+ }
+ }
+ set arglist $::env(QUERY_STRING)
+ set pwd [pwd]
+ cd [file dirname $local_file]
+ foreach {f v} [my request dump] {
+ if {$f in $verbatim} {
+ set ::env($f) $v
+ } else {
+ set ::env(HTTP_$f) $v
+ }
+ }
+ set script_file $local_file
+ if {[file extension $local_file] in {.fossil .fos}} {
+ if {![file exists $local_file.cgi]} {
+ set fout [open $local_file.cgi w]
+ chan puts $fout "#!/usr/bin/fossil"
+ chan puts $fout "repository: $local_file"
+ close $fout
+ }
+ set script_file $local_file.cgi
+ set EXE [my Cgi_Executable fossil]
+ } else {
+ set EXE [my Cgi_Executable $local_file]
+ }
+ set ::env(PATH_TRANSLATED) $script_file
+ set pipe [my CgiExec $EXE $script_file $arglist]
+ cd $pwd
+ return $pipe
+ }
+
+ method ProxyRequest {chana chanb} {
+ chan event $chanb writable {}
+ my log ProxyRequest {}
+ set length [my http_info get CONTENT_LENGTH]
+ if {$length} {
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
+ ###
+ # Send any POST/PUT/etc content
+ ###
+ chan copy $chana $chanb -size $length -command [info coroutine]
+ } else {
+ chan flush $chanb
+ chan event $chanb readable [info coroutine]
+ }
+ yield
+
+ }
+
+
+ method ProxyReply {chana chanb args} {
+ my log ProxyReply [list args $args]
+ chan event $chana readable {}
+ set replyhead [my HttpHeaders $chana]
+ set replydat [my MimeParse $replyhead]
+ if {![dict exists $replydat Content-Length]} {
+ set length 0
+ } else {
+ set length [dict get $replydat Content-Length]
+ }
+ ###
+ # Convert the Status: header from the CGI process to
+ # a standard service reply line from a web server, but
+ # otherwise spit out the rest of the headers verbatim
+ ###
+ set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
+ append replybuffer $replyhead
+ chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
+ chan puts $chanb $replybuffer
+ my log SendReply [list length $length]
+ if {$length} {
+ ###
+ # Output the body
+ ###
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan copy $chana $chanb -size $length -command [namespace code [list my TransferComplete $chana $chanb]]
+ } else {
+ my TransferComplete $chana $chanb
+ }
+ }
+
+ ###
+ # For most CGI applications a directory list is vorboten
+ ###
+ method DirectoryListing {local_file} {
+ my error 403 {Not Allowed}
+ tailcall my DoOutput
+ }
+}
+
+###
+# END: cgi.tcl
+###
###
# START: scgi.tcl
###
###
# Return data from an SCGI process
###
::tool::define ::httpd::content.scgi {
+ superclass ::httpd::content.proxy
method scgi_info {} {
###
# This method should check if a process is launched
# or launch it if needed, and return a list of
@@ -1040,148 +1671,92 @@
###
# return {localhost 8016 /some/path}
error unimplemented
}
- method content {} {
- my variable sock chan
+ method proxy_channel {} {
set sockinfo [my scgi_info]
if {$sockinfo eq {}} {
my error 404 {Not Found}
- return
+ tailcall my DoOutput
}
lassign $sockinfo scgihost scgiport scgiscript
- set sock [::socket $scgihost $scgiport]
-
- chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
- chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
- ###
- # Convert our query headers into netstring format.
- ###
-
- set info {CONTENT_LENGTH 0 SCGI 1.0}
- dict set info SCRIPT_NAME $scgiscript
- foreach {f v} [my http_info dump] {
- dict set info $f $v
- }
- foreach {fo v} [my request dump] {
- set f $fo
- switch [string tolower $fo] {
- content-length {
- set f CONTENT_LENGTH
- }
- content-type {
- set f CONTENT_TYPE
- }
- default {
- if {[string range $f 0 3] ne "HTTP" && $f ne "CONTENT_TYPE"} {
- set f HTTP_[string map {- _} [string toupper $f]]
- }
- }
- }
+ my http_info set SCRIPT_NAME $scgiscript
+ if {![string is integer $scgiport]} {
+ my error 404 {Not Found}
+ tailcall my DoOutput
+ }
+ return [::socket $scgihost $scgiport]
+ }
+
+ method ProxyRequest {chana chanb} {
+ chan event $chanb writable {}
+ my log ProxyRequest {}
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
+ set info [dict create CONTENT_LENGTH 0 SCGI 1.0 SCRIPT_NAME [my http_info get SCRIPT_NAME]]
+ foreach {f v} [my http_info dump] {
dict set info $f $v
}
set length [dict get $info CONTENT_LENGTH]
set block {}
foreach {f v} $info {
append block [string toupper $f] \x00 $v \x00
}
- chan puts -nonewline $sock "[string length $block]:$block,"
+ chan puts -nonewline $chanb "[string length $block]:$block,"
+ # Light off another coroutine
+ #set cmd [list coroutine [my CoroName] {*}[namespace code [list my ProxyReply $chanb $chana]]]
if {$length} {
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
###
# Send any POST/PUT/etc content
###
- chan copy $chan $sock -size $length
- }
- chan flush $sock
- ###
- # Wake this object up after the SCGI process starts to respond
- ###
- #chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
- chan event $sock readable [namespace code {my output}]
- }
-
- method output {} {
- if {[my http_info getnull HTTP_ERROR] ne {}} {
- ###
- # If something croaked internally, handle this page as a normal reply
- ###
- next
- }
- my variable sock chan
- set replyhead [my HttpHeaders $sock]
+ chan copy $chana $chanb -size $length -command [info coroutine]
+ } else {
+ chan flush $chanb
+ chan event $chanb readable [info coroutine]
+ }
+ yield
+ }
+
+ method ProxyReply {chana chanb args} {
+ my log ProxyReply [list args $args]
+ chan event $chana readable {}
+ set replyhead [my HttpHeaders $chana]
set replydat [my MimeParse $replyhead]
if {![dict exists $replydat Content-Length]} {
set length 0
} else {
set length [dict get $replydat Content-Length]
}
###
- # Convert the Status: header from the SCGI service to
+ # Convert the Status: header from the CGI process to
# a standard service reply line from a web server, but
# otherwise spit out the rest of the headers verbatim
###
- set replybuffer "HTTP/1.1 [dict get $replydat Status]\n"
+ set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
append replybuffer $replyhead
- chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
- puts $chan $replybuffer
- ###
- # Output the body
- ###
- chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
- chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
+ chan puts $chanb $replybuffer
+ my log SendReply [list length $length]
if {$length} {
###
- # Send any POST/PUT/etc content
+ # Output the body
###
- chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
+ chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan copy $chana $chanb -size $length -command [namespace code [list my TransferComplete $chana $chanb]]
} else {
- catch {close $sock}
- chan flush $chan
- my destroy
+ my TransferComplete $chan $chanb
}
}
}
tool::define ::httpd::reply.scgi {
superclass ::httpd::reply
- ###
- # A modified dispatch method from a standard HTTP reply
- # Unlike in HTTP, our headers were spoon fed to use from
- # the server
- ###
- method dispatch {newsock datastate} {
- my http_info replace $datastate
- my variable chan rawrequest dipatched_time
- set chan $newsock
- chan event $chan readable {}
- chan configure $chan -translation {auto crlf} -buffering line
- set dispatched_time [clock seconds]
- try {
- # Dispatch to the URL implementation.
- # Convert SCGI headers to mime-ish equivilients
- my reset
- foreach {f v} $datastate {
- switch $f {
- CONTENT_LENGTH {
- my request set Content-Length $v
- }
- default {
- my request set $f $v
- }
- }
- }
- my content
- } on error {err info} {
- #puts stderr $::errorInfo
- my error 500 $err [dict get $info -errorinfo]
- } finally {
- my output
- }
- }
-
method EncodeStatus {status} {
return "Status: $status"
}
}
@@ -1223,10 +1798,15 @@
# With length in hand, read the netstring encoded headers
set inbuffer [::coroutine::util::read $sock [expr {$size+1}]]
chan configure $sock -blocking 0 -buffersize 4096 -buffering full
foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] {
dict set query $f $v
+ if {$f in {CONTENT_LENGTH CONTENT_TYPE}} {
+ dict set query http $f $v
+ } elseif {[string range $f 0 4] eq "HTTP_"} {
+ dict set query http [string range $f 5 end] $v
+ }
}
if {![dict exists $query REQUEST_PATH]} {
set uri [dict get $query REQUEST_URI]
set uriinfo [::uri::split $uri]
dict set query REQUEST_PATH [dict get $uriinfo path]
@@ -1246,142 +1826,49 @@
$pageobj dispatch $sock $reply
my log HttpAccess $REQUEST_URI
} else {
try {
my log HttpMissing $REQUEST_URI
- puts $sock "Status: 404 NOT FOUND"
+ chan puts $sock "Status: 404 NOT FOUND"
dict with query {}
set body [subst [my template notfound]]
- puts $sock "Content-Length: [string length $body]"
- puts $sock {}
- puts $sock $body
+ chan puts $sock "Content-Length: [string length $body]"
+ chan puts $sock {}
+ chan puts $sock $body
} on error {err errdat} {
- puts stderr "FAILED ON 404: $err"
+ my debug "FAILED ON 404: $err [dict get $errdat -errorinfo]"
} finally {
- catch {close $sock}
+ catch {chan event readable $sock {}}
+ catch {chan event writeable $sock {}}
+ catch {chan close $sock}
}
}
} on error {err errdat} {
try {
- #puts stderr $::errorInfo
- puts $sock "Status: 505 INTERNAL ERROR - scgi 298"
+ my debug [dict get $errdat -errorinfo]
+ chan puts $sock "Status: 500 INTERNAL ERROR - scgi 298"
dict with query {}
set body [subst [my template internal_error]]
- puts $sock "Content-Length: [string length $body]"
- puts $sock {}
- puts $sock $body
- my log HttpError $REQUEST_URI
+ chan puts $sock "Content-Length: [string length $body]"
+ chan puts $sock {}
+ chan puts $sock $body
+ my log HttpError [list error [my http_info get REMOTE_ADDR] errorinfo [dict get $errdat -errorinfo]]
} on error {err errdat} {
- my log HttpFatal $::errorInfo
- #puts stderr "FAILED ON 505: $err $::errorInfo"
+ my log HttpFatal [list error [my http_info get REMOTE_ADDR] errorinfo [dict get $errdat -errorinfo]]
+ my debug "Failed on 500: [dict get $errdat -errorinfo]""
} finally {
- catch {close $sock}
+ catch {chan event readable $sock {}}
+ catch {chan event writeable $sock {}}
+ catch {chan close $sock}
}
}
}
}
###
# END: scgi.tcl
###
-###
-# START: proxy.tcl
-###
-
-# Act as a proxy server
-::tool::define ::httpd::content.proxy {
- # Options:
- # proxy_host - Hostname to proxy
- # proxy_port - Port on hostname to proxy
- # proxy_script - Block of text to stream before sending the request
- ###
-
- method proxy_info {} {
- ###
- # This method should check if a process is launched
- # or launch it if needed, and return a list of
- # HOST PORT PROXYURI
- ###
- # return {localhost 8016 /some/path}
- error unimplemented
- }
-
- method content {} {
- my variable chan sock rawrequest
- set sockinfo [my proxy_info]
- if {$sockinfo eq {}} {
- tailcall my error 404 {Not Found}
- }
-
- lassign $sockinfo proxyhost proxyport proxyscript
- set sock [::socket $proxyhost $proxyport]
-
- chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
- chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
-
- # Pass along our modified METHOD URI PROTO
- chan puts $sock "$proxyscript"
- # Pass along the headers as we saw them
- chan puts $sock $rawrequest
- set length [my http_info get CONTENT_LENGTH]
- if {$length} {
- ###
- # Send any POST/PUT/etc content
- ###
- chan copy $chan $sock -size $length
- }
- chan flush $sock
- ###
- # Wake this object up after the proxied process starts to respond
- ###
- chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
- chan event $sock readable [namespace code {my output}]
- }
-
- method DoOutput {} {
- my variable chan sock
- chan event $chan writable {}
- if {![info exists sock] || [my http_info getnull HTTP_ERROR] ne {}} {
- ###
- # If something croaked internally, handle this page as a normal reply
- ###
- next
- return
- }
- set length 0
- chan configure $sock -translation {crlf crlf} -blocking 1
- set replystatus [gets $sock]
- set replyhead [my HttpHeaders $sock]
- set replydat [my MimeParse $replyhead]
-
- ###
- # Pass along the status line and MIME headers
- ###
- set replybuffer "$replystatus\n"
- append replybuffer $replyhead
- chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
- chan puts $chan $replybuffer
- ###
- # Output the body
- ###
- chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
- chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
- set length [dict get $replydat CONTENT_LENGTH]
- if {$length} {
- ###
- # Send any POST/PUT/etc content
- ###
- chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
- } else {
- my destroy
- }
- }
-}
-
-###
-# END: proxy.tcl
-###
###
# START: websocket.tcl
###
###
# Upgrade a connection to a websocket
@@ -1391,10 +1878,231 @@
}
###
# END: websocket.tcl
###
+###
+# START: plugin.tcl
+###
+###
+# httpd plugin template
+###
+tool::define ::httpd::plugin {
+ ###
+ # Any options will be saved to the local config file
+ # to allow threads to pull up a snapshot of the object' configuration
+ ###
+
+ ###
+ # Define a code snippet to run on plugin load
+ ###
+ meta set plugin load: {}
+
+ ###
+ # Define a code snippet to run within the object's Headers_Process method
+ ###
+ meta set plugin headers: {}
+
+ ###
+ # Define a code snippet to run within the object's dispatch method
+ ###
+ meta set plugin dispatch: {}
+
+ ###
+ # Define a code snippet to run within the object's writes a local config file
+ ###
+ meta set plugin local_config: {}
+
+ ###
+ # When after all the plugins are loaded
+ # allow specially configured ones to light off a thread
+ ###
+ meta set plugin thread: {}
+
+}
+
+###
+# A rudimentary plugin that dispatches URLs from a dict
+# data structure
+###
+tool::define ::httpd::plugin.dict_dispatch {
+ meta set plugin dispatch: {
+ set reply [my Dispatch_Dict $data]
+ if {[dict size $reply]} {
+ return $reply
+ }
+ }
+
+ method Dispatch_Dict {data} {
+ set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
+ set uri [dict get $data REQUEST_PATH]
+ foreach {host pattern info} [my uri patterns] {
+ if {![string match $host $vhost]} continue
+ if {![string match $pattern $uri]} continue
+ set buffer $data
+ foreach {f v} $info {
+ dict set buffer $f $v
+ }
+ return $buffer
+ }
+ return {}
+ }
+
+ method uri::patterns {} {
+ my variable url_patterns url_stream
+ if {![info exists url_stream]} {
+ set url_stream {}
+ foreach {host hostpat} $url_patterns {
+ foreach {pattern info} $hostpat {
+ lappend url_stream $host $pattern $info
+ }
+ }
+ }
+ return $url_stream
+ }
+
+ method uri::add args {
+ my variable url_patterns url_stream
+ unset -nocomplain url_stream
+ switch [llength $args] {
+ 2 {
+ set vhosts *
+ lassign $args patterns info
+ }
+ 3 {
+ lassign $args vhosts patterns info
+ }
+ default {
+ error "Usage: add_url ?vhosts? prefix info"
+ }
+ }
+ foreach vhost $vhosts {
+ foreach pattern $patterns {
+ set data $info
+ if {![dict exists $data prefix]} {
+ dict set data prefix [my PrefixNormalize $pattern]
+ }
+ dict set url_patterns $vhost [string trimleft $pattern /] $data
+ }
+ }
+ }
+}
+
+tool::define ::httpd::reply.memchan {
+ superclass ::httpd::reply
+
+ method output {} {
+ my variable reply_body
+ return $reply_body
+ }
+
+ method DoOutput {} {}
+
+ method close {} {
+ # Neuter the channel closing mechanism we need the channel to stay alive
+ # until the reader sucks out the info
+ }
+}
+
+
+tool::define ::httpd::plugin.local_memchan {
+
+ meta set plugin load: {
+package require tcl::chan::events
+package require tcl::chan::memchan
+ }
+
+ method local_memchan {command args} {
+ my variable sock_to_coro
+ switch $command {
+ geturl {
+ ###
+ # Hook to allow a local process to ask for data without a socket
+ ###
+ set uuid [my Uuid_Generate]
+ set ip 127.0.0.1
+ set sock [::tcl::chan::memchan]
+ set output [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect_Local $uuid $sock GET {*}$args]]]
+ return $output
+ }
+ default {
+ error "Valid: connect geturl"
+ }
+ }
+ }
+
+ ###
+ # A modified connection method that passes simple GET request to an object
+ # and pulls data directly from the reply_body data variable in the object
+ #
+ # Needed because memchan is bidirectional, and we can't seem to communicate that
+ # the server is one side of the link and the reply is another
+ ###
+ method Connect_Local {uuid sock args} {
+ chan event $sock readable {}
+
+ chan configure $sock \
+ -blocking 0 \
+ -translation {auto crlf} \
+ -buffering line
+ set ip 127.0.0.1
+ dict set query UUID $uuid
+ dict set query HTTP_HOST localhost
+ dict set query REMOTE_ADDR 127.0.0.1
+ dict set query REMOTE_HOST localhost
+ dict set query LOCALHOST 1
+ my counter url_hit
+
+ dict set query REQUEST_METHOD [lindex $args 0]
+ set uriinfo [::uri::split [lindex $args 1]]
+ dict set query REQUEST_URI [lindex $args 1]
+ dict set query REQUEST_PATH [dict get $uriinfo path]
+ dict set query REQUEST_VERSION [lindex [split [lindex $args end] /] end]
+ dict set query DOCUMENT_ROOT [my cget doc_root]
+ dict set query QUERY_STRING [dict get $uriinfo query]
+ dict set query REQUEST_RAW $args
+ dict set query SERVER_PORT [my port_listening]
+ my Headers_Process query
+ set reply [my dispatch $query]
+
+ if {[llength $reply]==0} {
+ my log BadLocation $uuid $query
+ my log BadLocation $uuid $query
+ dict set query HTTP_STATUS 404
+ dict set query template notfound
+ dict set query mixinmap reply ::httpd::content.template
+ }
+
+ set class ::httpd::reply.memchan
+ set pageobj [$class create ::httpd::object::$uuid [self]]
+ if {[dict exists $reply mixinmap]} {
+ set mixinmap [dict get $reply mixinmap]
+ } else {
+ set mixinmap {}
+ }
+ if {[dict exists $reply mixin]} {
+ dict set mixinmap reply [dict get $reply mixin]
+ }
+ foreach item [dict keys $reply MIXIN_*] {
+ set slot [string range $reply 6 end]
+ dict set mixinmap [string tolower $slot] [dict get $reply $item]
+ }
+ $pageobj mixinmap {*}$mixinmap
+ if {[dict exists $reply organ]} {
+ $pageobj graft {*}[dict get $reply organ]
+ }
+ $pageobj dispatch $sock $reply
+ set output [$pageobj output]
+ catch {$pageobj destroy}
+ return $output
+ }
+}
+
+
+###
+# END: plugin.tcl
+###
namespace eval ::httpd {
namespace export *
}
Index: modules/httpd/httpd.test
==================================================================
--- modules/httpd/httpd.test
+++ modules/httpd/httpd.test
@@ -25,15 +25,27 @@
use dicttool/dicttool.tcl dicttool
use cron/cron.tcl cron
use oodialect/oodialect.tcl oo::dialect
use oometa/oometa.tcl oo::meta
use tool/tool.tcl tool
+ use virtchannel_core/core.tcl tcl::chan::core
+ use virtchannel_core/events.tcl tcl::chan::events
+ use virtchannel_base/memchan.tcl tcl::chan::memchan
}
testing {
useLocal httpd.tcl httpd
}
+
+# Set to true for debugging and traces
+set ::DEBUG 0
+
+proc DEBUG args {
+ if {$::DEBUG} {
+ uplevel 1 $args
+ }
+}
# -------------------------------------------------------------------------
namespace eval ::httpd {}
namespace eval ::httpd::test {}
@@ -68,21 +80,24 @@
set reply($sock) {}
chan configure $sock -translation {crlf crlf} -blocking 0 -buffering full -buffersize 4096
chan event $sock readable [list ::httpd::test::get_reply $sock]
puts $sock $http
+ if {![dict exists $headers Host]} {
+ dict set headers Host localhost
+ }
if {[string length $body]} {
if {![dict exists $headers Content-Type]} {
dict set headers Content_Type text/plain
}
dict set headers Content-Length [string length $body]
}
foreach {f v} $headers {
puts $sock "${f}: $v"
}
+ puts $sock {}
if {[string length $body]} {
- puts $sock {}
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
puts -nonewline $sock $body
}
flush $sock
while {$reply($sock) eq {}} {
@@ -104,10 +119,37 @@
}
tool::define ::httpd::server {
method log args {}
+
+
+ method TemplateSearch page {
+ set doc_root [my cget doc_root]
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
+ return [::fileutil::cat [file join $doc_root $page.tml]]
+ }
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
+ return [::fileutil::cat [file join $doc_root $page.html]]
+ }
+ switch $page {
+ redirect {
+ return {404 Not Found}
+ }
+ internal_error {
+ return {500 Server Internal Error}
+ }
+ }
+ }
+
+ ::DEBUG method debug args {
+ puts stderr $args
+ }
+
+ ::DEBUG method log args {
+ puts stdout $args
+ }
}
###
# Modify the reply class to return plain text
@@ -127,17 +169,12 @@
}
method error {code {msg {}} {errorInfo {}}} {
my http_info set HTTP_ERROR $code
my reset
- my variable error_codes
+ set errorstring [my http_code_string $code]
set qheaders [my http_info dump]
- if {![info exists error_codes($code)]} {
- set errorstring "Unknown Error Code"
- } else {
- set errorstring $error_codes($code)
- }
dict with qheaders {}
my reply replace {}
my reply set Status "$code $errorstring"
my reply set Content-Type text/plain
my puts "$code $errorstring"
@@ -145,11 +182,11 @@
}
tool::define ::test::content.echo {
method content {} {
my variable reply_body
- set reply_body [my PostData [my request get Content-Length]]
+ set reply_body [my PostData [my request get CONTENT_LENGTH]]
#puts [list REPLY BODY WAS $reply_body]
}
}
tool::define ::test::content.file {
superclass ::httpd::content.file
@@ -169,11 +206,14 @@
tool::define ::test::content.error {
method content {} {
error {The programmer asked me to die this way}
}
}
+tool::define ::test::content.cgi {
+ superclass ::httpd::content.cgi
+}
tool::define ::httpd::test::reply {
superclass ::httpd::reply ::test::content.echo
}
@@ -182,18 +222,21 @@
###
set DIR [file dirname [file normalize [info script]]]
set ::DEMOROOT $DIR
::httpd::server create TESTAPP port 10001
-TESTAPP add_uri / [list mixin ::test::content.echo]
-TESTAPP add_uri /echo [list mixin ::test::content.echo]
-TESTAPP add_uri /file [list mixin ::test::content.file doc_root $::DEMOROOT]
-TESTAPP add_uri /time [list mixin ::test::content.time]
-TESTAPP add_uri /error [list mixin ::test::content.error]
+TESTAPP plugin dict_dispatch
+TESTAPP uri add / [list mixin ::test::content.echo]
+TESTAPP uri add /echo [list mixin ::test::content.echo]
+TESTAPP uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
+TESTAPP uri add /time [list mixin ::test::content.time]
+TESTAPP uri add /error [list mixin ::test::content.error]
+
# Catch all
-#TESTAPP add_uri * [list mixin httpd::content.echo]
+#TESTAPP uri add * [list mixin httpd::content.echo]
+::DEBUG puts httpd-client-0001
test httpd-client-0001 {Do an echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS IS MY CODE}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
@@ -201,10 +244,11 @@
Content-Length: *
THIS IS MY CODE}
} {}
+::DEBUG puts httpd-client-0002
test httpd-client-0002 {Do another echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
@@ -211,10 +255,11 @@
Content-Length: 29
THOUGH THERE ARE MANY LIKE IT}
} {}
+::DEBUG puts httpd-client-0003
test httpd-client-0003 {Do another echo request} {
set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply {HTTP/1.0 200 OK
Content-Type: text/plain
Connection: close
@@ -221,10 +266,11 @@
Content-Length: *
THIS ONE ALONE IS MINE}
} {}
+::DEBUG puts httpd-client-0004
test httpd-client-0004 {URL Generates Error} {
set reply [::httpd::test::send 10001 {POST /error HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply {HTTP/1.0 500 Server Internal Error
@@ -240,10 +286,11 @@
Connection: close
Content-Length: *
[clock seconds]}]
+::DEBUG puts httpd-client-0005
test httpd-client-0005 {URL Different output with a different request} {
set reply [::httpd::test::send 10001 {POST /time HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply $checkreply
} {}
@@ -255,17 +302,173 @@
Connection: close
Content-Length: [string length $replyfile]
$replyfile"
+::DEBUG puts httpd-client-0006
test httpd-client-0006 {Return a file} {
set reply [::httpd::test::send 10001 {GET /file HTTP/1.0} {} {}]
::httpd::test::compare $reply $checkreply
} {}
+# -------------------------------------------------------------------------
+# Test proxies
+
+tool::define ::test::content.proxy {
+ superclass ::httpd::content.proxy
+
+
+ method proxy_channel {} {
+ return [::socket localhost [my http_info get proxy_port]]
+ }
+}
+
+
+::httpd::server create TESTPROXY port 10002
+TESTAPP uri add /proxy* [list mixin ::test::content.proxy proxy_port [TESTPROXY port_listening]]
+TESTPROXY plugin dict_dispatch
+TESTPROXY uri add / [list mixin ::test::content.echo]
+TESTPROXY uri add /echo [list mixin ::test::content.echo]
+TESTPROXY uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
+TESTPROXY uri add /time [list mixin ::test::content.time]
+TESTPROXY uri add /error [list mixin ::test::content.error]
+
+::DEBUG puts httpd-proxy-0001
+test httpd-proxy-0001 {Do an echo request} {
+
+set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS IS MY CODE}]
+::httpd::test::compare $reply {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-Length: *
+
+THIS IS MY CODE}
+} {}
+
+::DEBUG puts httpd-proxy-0002
+test httpd-proxy-0002 {Do another echo request} {
+set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THOUGH THERE ARE MANY LIKE IT}]
+::httpd::test::compare $reply {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-Length: 29
+
+THOUGH THERE ARE MANY LIKE IT}
+} {}
+
+::DEBUG puts httpd-proxy-0003
+test httpd-proxy-0003 {Do another echo request} {
+set reply [::httpd::test::send 10001 {POST /proxy/echo HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
+::httpd::test::compare $reply {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-Length: *
+
+THIS ONE ALONE IS MINE}
+} {}
+
+::DEBUG puts httpd-proxy-0004
+test httpd-proxy-0004 {URL Generates Error} {
+
+set reply [::httpd::test::send 10001 {POST /proxy/error HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
+
+::httpd::test::compare $reply {HTTP/1.0 500 Server Internal Error
+Content-Type: text/plain
+Connection: close
+Content-Length: *
+
+500 Server Internal Error}
+} {}
+
+set checkreply [subst {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-Length: *
+
+[clock seconds]}]
+
+::DEBUG puts httpd-proxy-0005
+test httpd-proxy-0005 {URL Different output with a different request} {
+set reply [::httpd::test::send 10001 {POST /proxy/time HTTP/1.0} {} {THIS ONE ALONE IS MINE}]
+::httpd::test::compare $reply $checkreply
+} {}
+
+set fin [open [file join $DEMOROOT pkgIndex.tcl] r]
+set replyfile [read $fin]
+close $fin
+set checkreply "HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-Length: [string length $replyfile]
+
+$replyfile"
+
+::DEBUG puts httpd-proxy-0006
+test httpd-proxy-0006 {Return a file} {
+set reply [::httpd::test::send 10001 {GET /proxy/file HTTP/1.0} {} {}]
+::httpd::test::compare $reply $checkreply
+} {}
+
+
+
+# -------------------------------------------------------------------------
+# cgi
+TESTAPP plugin local_memchan
+
+TESTAPP uri add /cgi-bin* [list mixin ::test::content.cgi path $::DEMOROOT]
+
+set fout [open [file join $DIR test.tcl] w]
+puts $fout {#!/usr/bin/tclsh
+
+puts stdout "Status: 200 OK"
+if {$::env(CONTENT_LENGTH) > 0} {
+ puts stdout "Content-Type: $::env(CONTENT_TYPE)"
+ set dat [read stdin $::env(CONTENT_LENGTH)]
+} else {
+ puts stdout "Content-Type: text/plain"
+ set dat "Hi!"
+}
+puts stdout "Content-Length: [string length $dat]"
+puts stdout {}
+puts stdout $dat
+exit 0
+}
+close $fout
+
+::DEBUG puts httpd-cgi-0001
+test httpd-cgi-0001 {CGI Post} {
+
+set reply [::httpd::test::send 10001 {POST /cgi-bin/test.tcl HTTP/1.0} {} {THIS IS MY CODE}]
+::httpd::test::compare $reply {HTTP/1.0 200 OK
+Status: 200 OK
+Content-Type: text/plain
+Content-Length: *
+
+THIS IS MY CODE}
+} {}
+
+::DEBUG puts httpd-cgi-0002
+test httpd-cgi-0002 {CGI Get} {
+
+set reply [::httpd::test::send 10001 {GET /cgi-bin/test.tcl HTTP/1.0} {} {}]
+::httpd::test::compare $reply {HTTP/1.0 200 OK
+Status: 200 OK
+Content-Type: text/plain
+Content-Length: *
+
+Hi!}
+} {}
+###
+# Test the local geturl method
+###
+set now [clock seconds]
+set dat [TESTAPP local_memchan geturl /time]
+test httpd-memchan-0001 {Memchan GET} {
+ TESTAPP local_memchan geturl /time
+} $now
# -------------------------------------------------------------------------
namespace eval ::scgi {}
namespace eval ::scgi::test {}
@@ -280,49 +483,42 @@
dict set outdict CONTENT_LENGTH [string length $body]
set outdict [dict merge $outdict $server_block $info]
dict set outdict PWD [pwd]
foreach {key value} $headers {
- switch $key {
- SCRIPT_NAME -
- REQUEST_METHOD -
- REQUEST_URI {
- dict set outdict $key $value
- }
- default {
- dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value
- }
+ if {$key in {
+ DOCUMENT_ROOT
+ HTTPS
+ PATH
+ REQUEST_METHOD REQUEST_URI
+ REMOTE_HOST REMOTE_ADDR REMOTE_PORT
+ SCRIPT_NAME
+ } || [string range $key 0 5] eq "HTTP_"} {
+ dict set outdict $key $value
+ } else {
+ dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value
}
}
set result {}
foreach {name value} $outdict {
append result $name \x00 $value \x00
}
return "[string length $result]:$result,"
}
-proc ::scgi::test::send {port text} {
+proc ::scgi::test::send {port headers body} {
set sock [socket localhost $port]
variable reply
set reply($sock) {}
+ if {![dict exists $headers HOST]} {
+ dict set headers HOST localhost
+ }
+ dict set headers REMOTE_IP 127.0.0.1
+ dict set headers REMOTE_HOST localhost
+
chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
chan event $sock readable [list ::scgi::test::get_reply $sock]
-
- set headers {}
- set body {}
- set read_headers 1
- foreach line [split $text \n] {
- if {$read_headers} {
- if { $line eq {} } {
- set read_headers 0
- } else {
- append headers $line \n
- }
- } else {
- append body $line \n
- }
- }
set block [::scgi::encode_request $headers $body {}]
puts -nonewline $sock $block
flush $sock
puts -nonewline $sock $body
flush $sock
@@ -359,79 +555,68 @@
my reply replace [my HttpHeaders_Default]
set reply_body {}
}
}
-TESTAPP destroy
-
###
# Build the server
###
tool::class create scgi::test::app {
superclass ::httpd::server.scgi
property reply_class ::scgi::test::reply
}
-scgi::test::app create TESTAPP port 10001
-
-TESTAPP add_uri / [list mixin ::test::content.echo]
-TESTAPP add_uri /echo [list mixin ::test::content.echo]
-TESTAPP add_uri /file [list mixin ::test::content.file doc_root $::DEMOROOT]
-TESTAPP add_uri /time [list mixin ::test::content.time]
-TESTAPP add_uri /error [list mixin ::test::content.error]
-
+scgi::test::app create TESTSCGI port 10003
+TESTSCGI plugin dict_dispatch
+TESTSCGI uri add / [list mixin ::test::content.echo]
+TESTSCGI uri add /echo [list mixin ::test::content.echo]
+TESTSCGI uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
+TESTSCGI uri add /time [list mixin ::test::content.time]
+TESTSCGI uri add /error [list mixin ::test::content.error]
+
+::DEBUG puts scgi-client-0001
test scgi-client-0001 {Do an echo request} {
-set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
-REQUEST_URI /echo
-
-THIS IS MY CODE}]
+set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS IS MY CODE}]
set checkreply {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-Length: *
THIS IS MY CODE}
::httpd::test::compare $reply $checkreply
} {}
+::DEBUG puts scgi-client-0002
test scgi-client-0002 {Do another echo request} {
-set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
-REQUEST_URI /echo
-
-THOUGH THERE ARE MANY LIKE IT}]
+set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THOUGH THERE ARE MANY LIKE IT}]
set checkreply {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-Length: *
THOUGH THERE ARE MANY LIKE IT}
::httpd::test::compare $reply $checkreply
} {}
+::DEBUG puts scgi-client-0003
test scgi-client-0003 {Do another echo request} {
-set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
-REQUEST_URI /echo
-
-THIS ONE ALONE IS MINE}]
+set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /echo} {THIS ONE ALONE IS MINE}]
set checkreply {Status: 200 OK
Content-Type: text/plain
Connection: close
Content-Length: *
THIS ONE ALONE IS MINE}
::httpd::test::compare $reply $checkreply
} {}
+::DEBUG puts scgi-client-0004
test scgi-client-0004 {URL Generates Error} {
-set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
-REQUEST_URI /error
-
-THIS ONE ALONE IS MINE
-}]
+set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /error} {THIS ONE ALONE IS MINE}]
set checkreply {Status: 500 Server Internal Error
Content-Type: text/plain
Connection: close
Content-Length: *
@@ -446,26 +631,24 @@
Connection: close
Content-Length: *
[clock seconds]}]
+::DEBUG puts scgi-client-0005
test scgi-client-0005 {URL Different output with a different request} {
-set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
-REQUEST_URI /time
-
-THIS ONE ALONE IS MINE}]
+set reply [::scgi::test::send 10003 {REQUEST_METHOD POST REQUEST_URI /time} {THIS ONE ALONE IS MINE}]
::httpd::test::compare $reply $checkreply
} {}
set fin [open [file join $DEMOROOT pkgIndex.tcl] r]
set checkfile [read $fin]
close $fin
+
+::DEBUG puts scgi-client-0006
test scgi-client-0006 {Return a file} {
-set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
-REQUEST_URI /file
-}]
+set reply [::scgi::test::send 10003 {REQUEST_METHOD GET REQUEST_URI /file} {}]
set checkreply "Status: 200 OK
Content-Type: text/plain
Connection: close
Content-Length: [string length $checkfile]
@@ -472,15 +655,15 @@
$checkfile"
::httpd::test::compare $reply $checkreply
} {}
-
+::DEBUG puts all-tests-finished
# -------------------------------------------------------------------------
testsuiteCleanup
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
Index: modules/httpd/pkgIndex.tcl
==================================================================
--- modules/httpd/pkgIndex.tcl
+++ modules/httpd/pkgIndex.tcl
@@ -1,4 +1,4 @@
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
-package ifneeded httpd 4.1.1 [list source [file join $dir httpd.tcl]]
+package ifneeded httpd 4.2.0 [list source [file join $dir httpd.tcl]]
DELETED modules/httpd/src/content.man
Index: modules/httpd/src/content.man
==================================================================
--- modules/httpd/src/content.man
+++ /dev/null
@@ -1,94 +0,0 @@
-[section {Class ::httpd::content}]
-
-The httpd module includes several ready to use implementations of content mixins
-for common use cases. Options are passed in to the [cmd add_uri] method of the server.
-
-[section {Class ::httpd::content.cgi}]
-
-An implementation to relay requests to process which will accept post data
-streamed in vie stdin, and sent a reply streamed to stdout.
-
-[list_begin definitions]
-[call method cgi_info]
-
-Mandatory method to be replaced by the end user. If needed, activates the
-process to proxy, and then returns a list of three values:
-
-[arg exec] - The arguments to send to exec to fire off the responding process, minus the stdin/stdout redirection.
-
-[list_end]
-
-[section {Class ::httpd::content.file}]
-
-An implementation to deliver files from the local file system.
-
-[list_begin definitions]
-
-[call option [cmd path]]
-
-The root directory on the local file system to be exposed via http.
-
-[call option [cmd prefix]]
-
-The prefix of the URI portion to ignore when calculating relative file paths.
-[list_end]
-
-[section {Class ::httpd::content.proxy}]
-
-An implementation to relay requests to another HTTP server, and relay
-the results back across the request channel.
-
-[list_begin definitions]
-[call method proxy_info]
-
-Mandatory method to be replaced by the end user. If needed, activates the
-process to proxy, and then returns a list of three values:
-
-[arg proxyhost] - The hostname where the proxy is located
-
-[arg proxyport] - The port to connect to
-
-[arg proxyscript] - A pre-amble block of text to send prior to the mirrored request
-
-[list_end]
-
-[section {Class ::httpd::content.scgi}]
-
-An implementation to relay requests to a server listening on a socket
-expecting SCGI encoded requests, and relay
-the results back across the request channel.
-
-[list_begin definitions]
-[call method scgi_info]
-
-Mandatory method to be replaced by the end user. If needed, activates the
-process to proxy, and then returns a list of three values:
-
-[arg scgihost] - The hostname where the scgi listener is located
-
-[arg scgiport] - The port to connect to
-
-[arg scgiscript] - The contents of the [arg SCRIPT_NAME] header to be sent
-
-[list_end]
-
-[section {Class ::httpd::content.websocket}]
-
-A placeholder for a future implementation to manage requests that can expect to be
-promoted to a Websocket. Currently it is an empty class.
-
-[section {SCGI Server Functions}]
-
-The HTTP module also provides an SCGI server implementation, as well as an HTTP
-implementation. To use the SCGI functions, create an object of the [cmd http::server.scgi]
-class instead of the [cmd http::server] class.
-
-[section {Class ::httpd::reply.scgi}]
-
-An modified [cmd http::reply] implementation that understands how to deal with
-netstring encoded headers.
-
-[section {Class ::httpd::server.scgi}]
-
-A modified [cmd http::server] which is tailored to replying to request according to
-the SCGI standard instead of the HTTP standard.
DELETED modules/httpd/src/core.tcl
Index: modules/httpd/src/core.tcl
==================================================================
--- modules/httpd/src/core.tcl
+++ /dev/null
@@ -1,33 +0,0 @@
-###
-# Author: Sean Woods, yoda@etoyoc.com
-##
-# Adapted from the "minihttpd.tcl" file distributed with Tclhttpd
-#
-# The working elements have been updated to operate as a TclOO object
-# running with Tcl 8.6+. Global variables and hard coded tables are
-# now resident with the object, allowing this server to be more easily
-# embedded another program, as well as be adapted and extended to
-# support the SCGI module
-###
-
-package require uri
-package require cron
-package require coroutine
-package require tool
-package require mime
-package require fileutil
-package require websocket
-###
-# Standard library of HTTP/SCGI content
-# Each of these classes are intended to be mixed into
-# either an HTTPD or SCGI reply
-###
-package require Markdown
-package require fileutil::magic::filetype
-namespace eval httpd::content {}
-
-namespace eval ::url {}
-namespace eval ::httpd {}
-namespace eval ::scgi {}
-
-
DELETED modules/httpd/src/dispatch.tcl
Index: modules/httpd/src/dispatch.tcl
==================================================================
--- modules/httpd/src/dispatch.tcl
+++ /dev/null
DELETED modules/httpd/src/file.tcl
Index: modules/httpd/src/file.tcl
==================================================================
--- modules/httpd/src/file.tcl
+++ /dev/null
@@ -1,162 +0,0 @@
-
-###
-# Class to deliver Static content
-# When utilized, this class is fed a local filename
-# by the dispatcher
-###
-::tool::define ::httpd::content.file {
-
- method FileName {} {
- set uri [string trimleft [my http_info get REQUEST_URI] /]
- set path [my http_info get path]
- set prefix [my http_info get prefix]
- set fname [string range $uri [string length $prefix] end]
- if {$fname in "{} index.html index.md index"} {
- return $path
- }
- if {[file exists [file join $path $fname]]} {
- return [file join $path $fname]
- }
- if {[file exists [file join $path $fname.md]]} {
- return [file join $path $fname.md]
- }
- if {[file exists [file join $path $fname.html]]} {
- return [file join $path $fname.html]
- }
- if {[file exists [file join $path $fname.tml]]} {
- return [file join $path $fname.tml]
- }
- return {}
- }
-
-
- method DirectoryListing {local_file} {
- set uri [string trimleft [my http_info get REQUEST_URI] /]
- set path [my http_info get path]
- set prefix [my http_info get prefix]
- set fname [string range $uri [string length $prefix] end]
- my puts "Listing of /$fname/ "
- my puts "Path: $path"
- if {$prefix ni {/ {}}} {
- set updir [file dirname $prefix]
- if {$updir ne {}} {
- my puts ".. [file tail $file]/ [file tail $file] [file size $file]
"
- }
-
- method dispatch {newsock datastate} {
- # No need to process the rest of the headers
- my variable chan dipatched_time
- set dispatched_time [clock seconds]
- my http_info replace $datastate
- set chan $newsock
- my content
- my output
- }
-
- method content {} {
- ###
- # When delivering static content, allow web caches to save
- ###
- my reply set Cache-Control {max-age=3600}
- my variable reply_file
- set local_file [my FileName]
- if {$local_file eq {} || ![file exist $local_file]} {
- my log httpNotFound [my http_info get REQUEST_URI]
- tailcall my error 404 {Not Found}
- }
- if {[file isdirectory $local_file]} {
- ###
- # Produce an index page
- ###
- set idxfound 0
- foreach name {
- index.html
- index.tml
- index.md
- } {
- if {[file exists [file join $local_file $name]]} {
- set idxfound 1
- set local_file [file join $local_file $name]
- break
- }
- }
- if {!$idxfound} {
- tailcall my DirectoryListing $local_file
- }
- }
- switch [file extension $local_file] {
- .md {
- package require Markdown
- my reply set Content-Type {text/html; charset=UTF-8}
- set mdtxt [::fileutil::cat $local_file]
- my puts [::Markdown::convert $mdtxt]
- }
- .tml {
- my reply set Content-Type {text/html; charset=UTF-8}
- set tmltxt [::fileutil::cat $local_file]
- set headers [my http_info dump]
- dict with headers {}
- my puts [subst $tmltxt]
- }
- default {
- ###
- # Assume we are returning a binary file
- ###
- my reply set Content-Type [::fileutil::magic::filetype $local_file]
- set reply_file $local_file
- }
- }
- }
-
- ###
- # Output the result or error to the channel
- # and destroy this object
- ###
- method DoOutput {} {
- my variable chan
- chan event $chan writable {}
- my variable reply_body reply_file reply_chan chan
- chan configure $chan -translation {binary binary}
- if {![info exists reply_file]} {
- ###
- # Return dynamic content
- ###
- if {![info exists reply_body]} {
- append result [my reply output]
- } else {
- set reply_body [string trim $reply_body]
- my reply set Content-Length [string length $reply_body]
- append result [my reply output] \n
- append result $reply_body
- chan puts -nonewline $chan $result
- chan flush $chan
- }
- my destroy
- } else {
- ###
- # Return a stream of data from a file
- ###
- set size [file size $reply_file]
- my reply set Content-Length $size
- append result [my reply output] \n
- chan puts -nonewline $chan $result
- set reply_chan [open $reply_file r]
- chan configure $reply_chan -translation {binary binary}
- chan copy $reply_chan $chan -command [namespace code [list my TransferComplete $reply_chan]]
- }
- }
-}
DELETED modules/httpd/src/proxy.tcl
Index: modules/httpd/src/proxy.tcl
==================================================================
--- modules/httpd/src/proxy.tcl
+++ /dev/null
@@ -1,90 +0,0 @@
-
-# Act as a proxy server
-::tool::define ::httpd::content.proxy {
- # Options:
- # proxy_host - Hostname to proxy
- # proxy_port - Port on hostname to proxy
- # proxy_script - Block of text to stream before sending the request
- ###
-
- method proxy_info {} {
- ###
- # This method should check if a process is launched
- # or launch it if needed, and return a list of
- # HOST PORT PROXYURI
- ###
- # return {localhost 8016 /some/path}
- error unimplemented
- }
-
- method content {} {
- my variable chan sock rawrequest
- set sockinfo [my proxy_info]
- if {$sockinfo eq {}} {
- tailcall my error 404 {Not Found}
- }
-
- lassign $sockinfo proxyhost proxyport proxyscript
- set sock [::socket $proxyhost $proxyport]
-
- chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
- chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
-
- # Pass along our modified METHOD URI PROTO
- chan puts $sock "$proxyscript"
- # Pass along the headers as we saw them
- chan puts $sock $rawrequest
- set length [my http_info get CONTENT_LENGTH]
- if {$length} {
- ###
- # Send any POST/PUT/etc content
- ###
- chan copy $chan $sock -size $length
- }
- chan flush $sock
- ###
- # Wake this object up after the proxied process starts to respond
- ###
- chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
- chan event $sock readable [namespace code {my output}]
- }
-
- method DoOutput {} {
- my variable chan sock
- chan event $chan writable {}
- if {![info exists sock] || [my http_info getnull HTTP_ERROR] ne {}} {
- ###
- # If something croaked internally, handle this page as a normal reply
- ###
- next
- return
- }
- set length 0
- chan configure $sock -translation {crlf crlf} -blocking 1
- set replystatus [gets $sock]
- set replyhead [my HttpHeaders $sock]
- set replydat [my MimeParse $replyhead]
-
- ###
- # Pass along the status line and MIME headers
- ###
- set replybuffer "$replystatus\n"
- append replybuffer $replyhead
- chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
- chan puts $chan $replybuffer
- ###
- # Output the body
- ###
- chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
- chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
- set length [dict get $replydat CONTENT_LENGTH]
- if {$length} {
- ###
- # Send any POST/PUT/etc content
- ###
- chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
- } else {
- my destroy
- }
- }
-}
DELETED modules/httpd/src/reply.man
Index: modules/httpd/src/reply.man
==================================================================
--- modules/httpd/src/reply.man
+++ /dev/null
@@ -1,302 +0,0 @@
-[section {Class ::httpd::reply}]
-
-A class which shephards a request through the process of generating a
-reply.
-
-The socket associated with the reply is available at all times as the [arg chan]
-variable.
-
-The process of generating a reply begins with an [cmd httpd::server] generating a
-[cmd http::class] object, mixing in a set of behaviors and then invoking the reply
-object's [cmd dispatch] method.
-
-In normal operations the [cmd dispatch] method:
-
-[list_begin enumerated]
-
-[enum]
-Invokes the [cmd reset] method for the object to populate default headers.
-
-[enum]
-Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket
-
-[enum]
-Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a
-dict that can be read via the [cmd request] method.
-
-[enum]
-Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object.
-
-[enum]
-Invokes the [cmd content] method for the object, generating an call to the [cmd error]
-method if an exception is raised.
-
-[enum]
-Invokes the [cmd output] method for the object
-[list_end]
-
-[para]
-
-[section {Reply Method Ensembles}]
-
-The [cmd http::reply] class and its derivatives maintain several variables as dictionaries
-internally. Access to these dictionaries is managed through a dedicated ensemble. The
-ensemble implements most of the same behaviors as the [cmd dict] command.
-
-Each ensemble implements the following methods above, beyond, or modifying standard dicts:
-
-[list_begin definitions]
-
-[call method [cmd ENSEMBLE::add] [arg field] [arg element]]
-
-Add [arg element] to a list stored in [arg field], but only if it is not already present om the list.
-
-[call method [cmd ENSEMBLE::dump]]
-
-Return the current contents of the data structure as a key/value list.
-
-[call method [cmd ENSEMBLE::get] [arg field]]
-
-Return the value of the field [arg field], or an empty string if it does not exist.
-
-[call method [cmd ENSEMBLE::reset]]
-
-Return a key/value list of the default contents for this data structure.
-
-[call method [cmd ENSEMBLE::remove] [arg field] [arg element]]
-
-Remove all instances of [arg element] from the list stored in [arg field].
-
-[call method [cmd ENSEMBLE::replace] [arg keyvaluelist]]
-
-Replace the internal dict with the contents of [arg keyvaluelist]
-
-[call method [cmd ENSEMBLE::reset]]
-
-Replace the internal dict with the default state.
-
-[call method [cmd ENSEMBLE::set] [arg field] [arg value]]
-
-Set the value of [arg field] to [arg value].
-
-[list_end]
-
-[section {Reply Method Ensemble: http_info}]
-
-Manages HTTP headers passed in by the server.
-
-Ensemble Methods:
-
-[list_begin definitions]
-
-[call method [cmd http_info::netstring]]
-
-Return the contents of this data structure as a netstring encoded block.
-
-[list_end]
-
-[section {Reply Method Ensemble: request}]
-
-Managed data from MIME headers of the request.
-
-[list_begin definitions]
-
-[call method [cmd request::parse] [arg string]]
-
-Replace the contents of the data structure with information encoded in a MIME
-formatted block of text ([arg string]).
-
-[list_end]
-
-[section {Reply Method Ensemble: reply}]
-
-Manage the headers sent in the reply.
-
-
-[list_begin definitions]
-
-[call method [cmd reply::output]]
-
-Return the contents of this data structure as a MIME encoded block appropriate
-for an HTTP response.
-
-[list_end]
-
-[section {Reply Methods}]
-
-[list_begin definitions]
-[call method [cmd close]]
-
-Terminate the transaction, and close the socket.
-
-[call method [cmd HttpHeaders] [arg sock] [arg ?debug?]]
-
-Stream MIME headers from the socket [arg sock], stopping at an empty line. Returns
-the stream as a block of text.
-
-[call method [cmd dispatch] [arg newsock] [arg datastate]]
-
-Take over control of the socket [arg newsock], and store that as the [arg chan] variable
-for the object. This method runs through all of the steps of reading HTTP headers, generating
-content, and closing the connection. (See class writetup).
-
-[call method [cmd error] [arg code] [arg ?message?] [arg ?errorInfo?]]
-
-Generate an error message of the specified [arg code], and display the [arg message] as the
-reason for the exception. [arg errorInfo] is passed in from calls, but how or if it should be
-displayed is a prerogative of the developer.
-
-[call method [cmd content]]
-
-Generate the content for the reply. This method is intended to be replaced by the mixin.
-
-Developers have the option of streaming output to a buffer via the [cmd puts] method of the
-reply, or simply populating the [arg reply_body] variable of the object.
-The information returned by the [cmd content] method is not interpreted in any way.
-
-If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will
-auto-generate a 505 {Internal Error} message.
-
-A typical implementation of [cmd content] look like:
-
-[example {
-
-tool::define ::test::content.file {
- superclass ::httpd::content.file
- # Return a file
- # Note: this is using the content.file mixin which looks for the reply_file variable
- # and will auto-compute the Content-Type
- method content {} {
- my reset
- set doc_root [my http_info get doc_root]
- my variable reply_file
- set reply_file [file join $doc_root index.html]
- }
-}
-tool::define ::test::content.time {
- # return the current system time
- method content {} {
- my variable reply_body
- my reply set Content-Type text/plain
- set reply_body [clock seconds]
- }
-}
-tool::define ::test::content.echo {
- method content {} {
- my variable reply_body
- my reply set Content-Type [my request get Content-Type]
- set reply_body [my PostData [my request get Content-Length]]
- }
-}
-tool::define ::test::content.form_handler {
- method content {} {
- set form [my FormData]
- my reply set Content-Type {text/html; charset=UTF-8}
- my puts ""
- my puts ""
- my puts "You Sent"
- my puts "
"
- foreach {f v} $form {
- my puts "$f $v
"
- my puts "Send some info:
"
- my puts "