clay get server/ string]
my reply set Date [my timestamp]
set reply_body {}
}
method timeOutCheck {} {
my variable dispatched_time
if {([clock seconds]-$dispatched_time)>120} {
###
# Something has lasted over 2 minutes. Kill this
###
catch {
my error 408 {Request Timed out}
my DoOutput
}
}
}
method timestamp {} {
return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
}
}
###
# END: reply.tcl
###
###
# START: server.tcl
###
namespace eval ::httpd::object {
}
namespace eval ::httpd::coro {
}
::clay::define ::httpd::server {
superclass ::httpd::mime
clay set server/ port auto
clay set server/ myaddr 127.0.0.1
clay set server/ string [list TclHttpd $::httpd::version]
clay set server/ name [info hostname]
clay set server/ doc_root {}
clay set server/ reverse_dns 0
clay set server/ configuration_file {}
clay set server/ protocol {HTTP/1.1}
clay set socket/ buffersize 32768
clay set socket/ translation {auto crlf}
clay set reply_class ::httpd::reply
Array template
Dict url_patterns {}
constructor {
{args {
port {default auto comment {Port to listen on}}
myaddr {default 127.0.0.1 comment {IP address to listen on. "all" means all}}
string {default auto comment {Value for SERVER_SOFTWARE in HTTP headers}}
name {default auto comment {Value for SERVER_NAME in HTTP headers. Defaults to [info hostname]}}
doc_root {default {} comment {File path to serve.}}
reverse_dns {default 0 comment {Perform reverse DNS to convert IPs into hostnames}}
configuration_file {default {} comment {Configuration file to load into server namespace}}
protocol {default {HTTP/1.1} comment {Value for SERVER_PROTOCOL in HTTP headers}}
}}} {
if {[llength $args]==1} {
set arglist [lindex $args 0]
} else {
set arglist $args
}
foreach {var val} $arglist {
my clay set server/ $var $val
}
my start
}
destructor {
my stop
}
method connect {sock ip port} {
###
# If an IP address is blocked drop the
# connection
###
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 ServerHeaders {ip http_request mimetxt} {
set result {}
dict set result HTTP_HOST {}
dict set result CONTENT_LENGTH 0
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 result $qfld $v
}
dict set result REMOTE_ADDR $ip
dict set result REMOTE_HOST [my HostName $ip]
dict set result REQUEST_METHOD [lindex $http_request 0]
set uriinfo [::uri::split [lindex $http_request 1]]
dict set result uriinfo $uriinfo
dict set result REQUEST_URI [lindex $http_request 1]
dict set result REQUEST_PATH [dict get $uriinfo path]
dict set result REQUEST_VERSION [lindex [split [lindex $http_request end] /] end]
dict set result DOCUMENT_ROOT [my clay get server/ doc_root]
dict set result QUERY_STRING [dict get $uriinfo query]
dict set result REQUEST_RAW $http_request
dict set result SERVER_PORT [my port_listening]
dict set result SERVER_NAME [my clay get server/ name]
dict set result SERVER_PROTOCOL [my clay get server/ protocol]
dict set result SERVER_SOFTWARE [my clay get server/ string]
if {[string match 127.* $ip]} {
dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}]
}
return $result
}
method Connect {uuid sock ip} {
::clay::cleanup
yield [info coroutine]
chan event $sock readable {}
chan configure $sock \
-blocking 0 \
-translation {auto crlf} \
-buffering line
my counter url_hit
try {
set readCount [::coroutine::util::gets_safety $sock 4096 http_request]
set mimetxt [my HttpHeaders $sock]
dict set query UUID $uuid
dict set query mimetxt $mimetxt
dict set query mixin style [my clay get server/ style]
dict set query http [my ServerHeaders $ip $http_request $mimetxt]
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 {[dict size $reply]==0} {
set reply $query
my log BadLocation $uuid $query
dict set reply http HTTP_STATUS {404 Not Found}
dict set reply template notfound
dict set reply mixin reply ::httpd::content.template
}
set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
tailcall $pageobj dispatch $sock $reply
}
method counter which {
my variable counters
incr counters($which)
}
method CheckTimeout {} {
foreach obj [info commands ::httpd::object::*] {
try {
$obj timeOutCheck
} on error {} {
$obj clay refcount_decr
}
}
::clay::cleanup
}
method debug args {}
method dispatch {data} {
set reply [my Dispatch_Local $data]
if {[dict size $reply]} {
return $reply
}
return [my Dispatch_Default $data]
}
method Dispatch_Default {reply} {
###
# Fallback to docroot handling
###
set doc_root [dict getnull $reply http 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 reply httpd::content.file
return $reply
}
return {}
}
method Dispatch_Local data {}
method Headers_Local {varname} {}
method Headers_Process varname {}
method HostName ipaddr {
if {![my clay get server/ 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 clay mixinmap $slot $class
set mixinmap [my clay mixinmap]
###
# Perform action on load
###
set script [$class clay search plugin/ load]
eval $script
###
# rebuild the dispatch method
###
set body "\n try \{"
append body \n {
set reply [my Dispatch_Local $data]
if {[dict size $reply]} {return $reply}
}
foreach {slot class} $mixinmap {
set script [$class clay search 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"
append body \n { my Headers_Local query}
foreach {slot class} $mixinmap {
set script [$class clay search 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 clay search 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 clay get server/ configuration_file] ne {}} {
source [my clay get server/ configuration_file]
}
set port [my clay get server/ port]
if { $port in {auto {}} } {
package require nettool
set port [::nettool::allocate_port 8015]
}
set port_listening $port
set myaddr [my clay get server/ 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]
}
Ensemble SubObject::db {} {
return [namespace current]::Sqlite_db
}
Ensemble SubObject::default {} {
return [namespace current]::$method
}
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 clay get server/ 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 request get REQUEST_PATH] 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 request get REQUEST_PATH]:
The server encountered an internal server error:
$msg
$errorInfo
[my html_footer]
}
}
notfound {
return {
[my html_header "$HTTP_STATUS"]
The page you are looking for: [my request get REQUEST_PATH] does not exist.
[my html_footer]
}
}
}
}
method Thread_start {} {}
method Uuid_Generate {} {
return [::clay::uuid::short]
}
method Validate_Connection {sock ip} {
return 0
}
}
::clay::define ::httpd::server::dispatch {
superclass ::httpd::server
}
###
# END: server.tcl
###
###
# START: dispatch.tcl
###
::clay::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 clay get server/ string]
set msg [my clay get LOCATION]
my reply set Location [my clay get LOCATION]
set code [my clay get 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 clay get LOCATION]
set HTTP_STATUS [my reply get Status]
my puts [subst $msg]
}
}
::clay::define ::httpd::content.cache {
method Dispatch {} {
my variable chan
my wait writable $chan
chan configure $chan -translation {binary binary}
chan puts -nonewline $chan [my clay get cache/ data]
}
}
::clay::define ::httpd::content.template {
method content {} {
if {[my request get HTTP_STATUS] ne {}} {
my reply set Status [my request get HTTP_STATUS]
}
set request [my request dump]
dict with request {}
my puts [subst [my template [my clay get template]]]
}
}
###
# END: dispatch.tcl
###
###
# START: file.tcl
###
::clay::define ::httpd::content.file {
method FileName {} {
# Some dispatchers will inject a fully qualified name during discovery
if {[my clay exists FILENAME] && [file exists [my clay get FILENAME]]} {
my request set PREFIX_URI [file dirname [my clay get FILENAME]]
return [my clay get FILENAME]
}
set uri [string trimleft [my request get REQUEST_PATH] /]
set path [my clay get path]
set prefix [my clay get prefix]
set fname [string range $uri [string length $prefix] end]
if {$fname in "{} index.html index.md index index.tml index.tcl"} {
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]
}
if {[file exists [file join $path $fname.tcl]]} {
return [file join $path $fname.tcl]
}
return {}
}
method DirectoryListing {local_file} {
set uri [string trimleft [my request get REQUEST_PATH] /]
set path [my clay get path]
set prefix [my clay get prefix]
set fname [string range $uri [string length $prefix] end]
my puts [my html_header "Listing of /$fname/"]
my puts "Listing contents of /$fname/"
my puts ""
if {$prefix ni {/ {}}} {
set updir [file dirname $prefix]
if {$updir ne {}} {
my puts ".. | |
"
}
}
foreach file [glob -nocomplain [file join $local_file *]] {
if {[file isdirectory $file]} {
my puts "[file tail $file]/ | |
"
} else {
my puts "[file tail $file] | [file size $file] |
"
}
}
my puts "
"
my puts [my html_footer]
}
method content {} {
my variable reply_file
set local_file [my FileName]
if {$local_file eq {} || ![file exist $local_file]} {
my log httpNotFound [my request get REQUEST_PATH]
my error 404 {File Not Found}
tailcall my DoOutput
}
if {[file isdirectory $local_file] || [file tail $local_file] in {index index.html index.tml index.md}} {
my request set PREFIX_URI [my request get REQUEST_PATH]
my request set LOCAL_DIR $local_file
###
# Produce an index page
###
set idxfound 0
foreach name {
index.tcl
index.html
index.tml
index.md
index.info
index.clay
content.htm
} {
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
}
} else {
my request set PREFIX_URI [file dirname [my request get REQUEST_PATH]]
my request set LOCAL_DIR [file dirname $local_file]
}
my request set LOCAL_FILE $local_file
switch [file extension $local_file] {
.apng {
my reply set Content-Type {image/apng}
set reply_file $local_file
}
.bmp {
my reply set Content-Type {image/bmp}
set reply_file $local_file
}
.css {
my reply set Content-Type {text/css}
set reply_file $local_file
}
.gif {
my reply set Content-Type {image/gif}
set reply_file $local_file
}
.cur - .ico {
my reply set Content-Type {image/x-icon}
set reply_file $local_file
}
.jpg - .jpeg - .jfif - .pjpeg - .pjp {
my reply set Content-Type {image/jpg}
set reply_file $local_file
}
.js {
my reply set Content-Type {text/javascript}
set reply_file $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]
}
.png {
my reply set Content-Type {image/png}
set reply_file $local_file
}
.svgz -
.svg {
# FU magic screws it up
my reply set Content-Type {image/svg+xml}
set reply_file $local_file
}
.tcl {
my reply set Content-Type {text/html; charset=UTF-8}
try {
source $local_file
} on error {err errdat} {
my error 500 {Internal Error} [dict get $errdat -errorinfo]
}
}
.tiff {
my reply set Content-Type {image/tiff}
set reply_file $local_file
}
.tml {
my reply set Content-Type {text/html; charset=UTF-8}
set tmltxt [::fileutil::cat $local_file]
set headers [my request dump]
dict with headers {}
my puts [subst $tmltxt]
}
.txt {
my reply set Content-Type {text/plain}
set reply_file $local_file
}
.webp {
my reply set Content-Type {image/webp}
set reply_file $local_file
}
default {
###
# Assume we are returning a binary file
###
my reply set Content-Type [::httpd::mime-type $local_file]
set reply_file $local_file
}
}
}
method Dispatch {} {
my variable reply_body reply_file reply_chan chan
try {
my reset
# Invoke the URL implementation.
my content
} on error {err errdat} {
my error 500 $err [dict get $errdat -errorinfo]
catch {
tailcall my DoOutput
}
}
if {$chan eq {}} return
catch {
# Causing random issues. Technically a socket is always open for read and write
# anyway
#my wait writable $chan
if {![info exists reply_file]} {
tailcall my DoOutput
}
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 ChannelRegister $reply_chan
my log SendReply [list length $size]
###
# Output the file contents. With no -size flag, channel will copy until EOF
###
chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0
if {$size < 40960} {
# Raw copy small files
chan copy $reply_chan $chan
} else {
my ChannelCopy $reply_chan $chan -chunk 4096
}
}
}
}
###
# END: file.tcl
###
###
# START: proxy.tcl
###
::clay::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 clay get tcl_exe] ne {}} {
dict set exename $which [my clay get tcl_exe]
} else {
dict set exename $which [info nameofexecutable]
}
} else {
if {[my clay get ${which}_exe] ne {}} {
dict set exename $which [my clay get ${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
}
}
::clay::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 request get REQUEST_URI] /]
set prefix [my clay 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 request get REQUEST_METHOD] [my proxy_path]"
set mimetxt [my clay get mimetxt]
chan puts $chanb [my clay get mimetxt]
set length [my request 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
###
my ChannelCopy $chana $chanb -size $length
} 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]
###
# 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
###
# Output the body. With no -size flag, channel will copy until EOF
###
chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
my ChannelCopy $chana $chanb -chunk 4096
}
method Dispatch {} {
my variable sock chan
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 ChannelRegister $sock
my ProxyRequest $chan $sock
my ProxyReply $sock $chan
}
}
###
# END: proxy.tcl
###
###
# START: cgi.tcl
###
::clay::define ::httpd::content.cgi {
superclass ::httpd::content.proxy
method FileName {} {
set uri [string trimleft [my request get REQUEST_PATH] /]
set path [my clay get path]
set prefix [my clay 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 request get REQUEST_PATH]
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 request get REQUEST_PATH]
set ::env(SERVER_PROTOCOL) HTTP/1.0
set ::env(HOME) $::env(DOCUMENT_ROOT)
foreach {f v} [my request dump] {
set ::env($f) $v
}
set arglist $::env(QUERY_STRING)
set pwd [pwd]
cd [file dirname $local_file]
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 request 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
###
my ChannelCopy $chana $chanb -size $length
} else {
chan flush $chanb
}
my clay refcount_incr
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
###
# Output the body. With no -size flag, channel will copy until EOF
###
chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
my ChannelCopy $chana $chanb -chunk 4096
my clay refcount_decr
}
method DirectoryListing {local_file} {
my error 403 {Not Allowed}
tailcall my DoOutput
}
}
###
# END: cgi.tcl
###
###
# START: scgi.tcl
###
::clay::define ::httpd::protocol.scgi {
method EncodeStatus {status} {
return "Status: $status"
}
}
::clay::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
# HOST PORT SCRIPT_NAME
###
# return {localhost 8016 /some/path}
error unimplemented
}
method proxy_channel {} {
set sockinfo [my scgi_info]
if {$sockinfo eq {}} {
my error 404 {Not Found}
tailcall my DoOutput
}
lassign $sockinfo scgihost scgiport scgiscript
my clay 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 clay get SCRIPT_NAME]]
foreach {f v} [my request 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 $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
###
my ChannelCopy $chana $chanb -size $length
#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]
###
# 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
###
# Output the body. With no -size flag, channel will copy until EOF
###
chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
my ChannelCopy $chana $chanb -chunk 4096
}
}
::clay::define ::httpd::server.scgi {
superclass ::httpd::server
clay set socket/ buffersize 32768
clay set socket/ blocking 0
clay set socket/ translation {binary binary}
method debug args {
puts $args
}
method Connect {uuid sock ip} {
yield [info coroutine]
chan event $sock readable {}
chan configure $sock \
-blocking 1 \
-translation {binary binary} \
-buffersize 4096 \
-buffering none
my counter url_hit
try {
# Read the SCGI request on byte at a time until we reach a ":"
dict set query http HTTP_HOST {}
dict set query http CONTENT_LENGTH 0
dict set query http REQUEST_URI /
dict set query http REMOTE_ADDR $ip
dict set query http DOCUMENT_ROOT [my clay get server/ doc_root]
set size {}
while 1 {
set char [::coroutine::util::read $sock 1]
if {[chan eof $sock]} {
catch {close $sock}
return
}
if {$char eq ":"} break
append size $char
}
# With length in hand, read the netstring encoded headers
set inbuffer [::coroutine::util::read $sock [expr {$size+1}]]
chan configure $sock -translation {auto crlf} -blocking 0 -buffersize 4096 -buffering full
foreach {f v} [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1] {
dict set query http $f $v
}
if {![dict exists $query http REQUEST_PATH]} {
set uri [dict get $query http REQUEST_URI]
set uriinfo [::uri::split $uri]
dict set query http REQUEST_PATH [dict get $uriinfo path]
}
set reply [my dispatch $query]
} on error {err errdat} {
my debug [list uri: [dict getnull $query http 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 event readable $sock {}}
catch {chan event writeable $sock {}}
catch {chan close $sock}
return
}
if {[dict size $reply]==0} {
my log BadLocation $uuid $query
dict set query http HTTP_STATUS 404
dict set query template notfound
dict set query mixin reply ::httpd::content.template
}
try {
set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
dict set reply mixin protocol ::httpd::protocol.scgi
$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]]
$pageobj clay refcount_decr
catch {chan event readable $sock {}}
catch {chan event writeable $sock {}}
catch {chan close $sock}
return
}
}
}
###
# END: scgi.tcl
###
###
# START: websocket.tcl
###
::clay::define ::httpd::content.websocket {
}
###
# END: websocket.tcl
###
###
# START: plugin.tcl
###
::clay::define ::httpd::plugin {
clay set plugin/ load {}
clay set plugin/ headers {}
clay set plugin/ dispatch {}
clay set plugin/ local_config {}
clay set plugin/ thread {}
}
::clay::define ::httpd::plugin.dict_dispatch {
clay set plugin/ dispatch {
set reply [my Dispatch_Dict $data]
if {[dict size $reply]} {
return $reply
}
}
method Dispatch_Dict {data} {
my variable url_patterns
set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
set uri [dict get $data http REQUEST_PATH]
foreach {host hostpat} $url_patterns {
if {![string match $host $vhost]} continue
foreach {pattern info} $hostpat {
if {![string match $pattern $uri]} continue
set buffer $data
foreach {f v} $info {
dict set buffer $f $v
}
return $buffer
}
}
return {}
}
Ensemble uri::add {vhosts patterns info} {
my variable url_patterns
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
}
}
}
Ensemble uri::direct {vhosts patterns info body} {
my variable url_patterns url_stream
set cbody {}
if {[dict exists $info superclass]} {
append cbody \n "superclass {*}[dict get $info superclass]"
dict unset info superclass
}
append cbody \n [list method content {} $body]
set class [namespace current]::${vhosts}/${patterns}
set class [string map {* %} $class]
::clay::define $class $cbody
dict set info mixin content $class
my uri add $vhosts $patterns $info
}
}
::clay::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
}
}
::clay::define ::httpd::plugin.local_memchan {
clay 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"
}
}
}
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 UUID $uuid
dict set query http HTTP_HOST localhost
dict set query http REMOTE_ADDR 127.0.0.1
dict set query http REMOTE_HOST localhost
dict set query http LOCALHOST 1
my counter url_hit
dict set query http REQUEST_METHOD [lindex $args 0]
set uriinfo [::uri::split [lindex $args 1]]
dict set query http REQUEST_URI [lindex $args 1]
dict set query http REQUEST_PATH [dict get $uriinfo path]
dict set query http REQUEST_VERSION [lindex [split [lindex $args end] /] end]
dict set query http DOCUMENT_ROOT [my clay get server/ doc_root]
dict set query http QUERY_STRING [dict get $uriinfo query]
dict set query http REQUEST_RAW $args
dict set query http 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 HTTP_STATUS 404
dict set query template notfound
dict set query mixin reply ::httpd::content.template
}
set class ::httpd::reply.memchan
set pageobj [$class create ::httpd::object::$uuid [self]]
if {[dict exists $reply mixin]} {
set mixinmap [dict get $reply mixin]
} else {
set mixinmap {}
}
foreach item [dict keys $reply MIXIN_*] {
set slot [string range $reply 6 end]
dict set mixinmap [string tolower $slot] [dict get $reply $item]
}
$pageobj clay mixinmap {*}$mixinmap
if {[dict exists $reply delegate]} {
$pageobj clay delegate {*}[dict get $reply delegate]
}
$pageobj dispatch $sock $reply
set output [$pageobj output]
$pageobj clay refcount_decr
return $output
}
}
###
# END: plugin.tcl
###
###
# START: cuneiform.tcl
###
###
# END: cuneiform.tcl
###
namespace eval ::httpd {
namespace export *
}