Attachment "H.tcl" to
ticket [0b874c344d]
added by
cmcc
2013-11-23 18:42:03.
# H.tcl - light Httpd 1.1
if {[info exists argv0] && ($argv0 eq [info script])} {
apply {{} {
set home [file dirname [file normalize [info script]]]
lappend ::auto_path $home [file join [file dirname $home] Utilities] [file join [file dirname $home] extensions]
}}
#puts [info script]:$::auto_path
}
if {[catch {
package require xxxDebug
}]} {
proc ::Debug {args} {}
foreach tag {error httpd listener httpdlow httpdtxlow entity cache cookies} {
interp alias {} Debug.$tag {} ::Debug
}
} else {
Debug on error
Debug define httpd
Debug define listener
Debug define httpdlow
Debug define httpdtxlow
Debug define entity
Debug define cache
Debug define cookies
}
if {[llength [info commands ::yieldm]] == 0} {
proc ::yieldm {value} {
yieldto return -level 0 $value
}
}
package provide H 7.0
interp alias {} tclarmour {} string map {\[ "[" \] "]" \{ "{" \} "}" $ "$"}
interp alias {} armour {} string map {
&\# &\# ' &\#39;
\xa0 \xa1 ¡ \xa2 ¢ \xa3 £ \xa4 ¤
\xa5 ¥ \xa6 ¦ \xa7 § \xa8 ¨ \xa9 ©
\xaa ª \xab « \xac ¬ \xad ­ \xae ®
\xaf ¯ \xb0 ° \xb1 ± \xb2 ² \xb3 ³
\xb4 ´ \xb5 µ \xb6 ¶ \xb7 · \xb8 ¸
\xb9 ¹ \xba º \xbb » \xbc ¼ \xbd ½
\xbe ¾ \xbf ¿ \xc0 À \xc1 Á \xc2 Â
\xc3 Ã \xc4 Ä \xc5 Å \xc6 Æ \xc7 Ç
\xc8 È \xc9 É \xca Ê \xcb Ë \xcc Ì
\xcd Í \xce Î \xcf Ï \xd0 Ð \xd1 Ñ
\xd2 Ò \xd3 Ó \xd4 Ô \xd5 Õ \xd6 Ö
\xd7 × \xd8 Ø \xd9 Ù \xda Ú \xdb Û
\xdc Ü \xdd Ý \xde Þ \xdf ß \xe0 à
\xe1 á \xe2 â \xe3 ã \xe4 ä \xe5 å
\xe6 æ \xe7 ç \xe8 è \xe9 é \xea ê
\xeb ë \xec ì \xed í \xee î \xef ï
\xf0 ð \xf1 ñ \xf2 ò \xf3 ó \xf4 ô
\xf5 õ \xf6 ö \xf7 ÷ \xf8 ø \xf9 ù
\xfa ú \xfb û \xfc ü \xfd ý \xfe þ
\xff ÿ \u192 ƒ \u391 Α \u392 Β \u393 Γ
\u394 Δ \u395 Ε \u396 Ζ \u397 Η \u398 Θ
\u399 Ι \u39A Κ \u39B Λ \u39C Μ \u39D Ν
\u39E Ξ \u39F Ο \u3A0 Π \u3A1 Ρ \u3A3 Σ
\u3A4 Τ \u3A5 Υ \u3A6 Φ \u3A7 Χ \u3A8 Ψ
\u3A9 Ω \u3B1 α \u3B2 β \u3B3 γ \u3B4 δ
\u3B5 ε \u3B6 ζ \u3B7 η \u3B8 θ \u3B9 ι
\u3BA κ \u3BB λ \u3BC μ \u3BD ν \u3BE ξ
\u3BF ο \u3C0 π \u3C1 ρ \u3C2 ς \u3C3 σ
\u3C4 τ \u3C5 υ \u3C6 φ \u3C7 χ \u3C8 ψ
\u3C9 ω \u3D1 ϑ \u3D2 ϒ \u3D6 ϖ
\u2022 • \u2026 … \u2032 ′ \u2033 ″
\u203E ‾ \u2044 ⁄ \u2118 ℘ \u2111 ℑ
\u211C ℜ \u2122 ™ \u2135 ℵ \u2190 ←
\u2191 ↑ \u2192 → \u2193 ↓ \u2194 ↔ \u21B5 ↵
\u21D0 ⇐ \u21D1 ⇑ \u21D2 ⇒ \u21D3 ⇓ \u21D4 ⇔
\u2200 ∀ \u2202 ∂ \u2203 ∃ \u2205 ∅
\u2207 ∇ \u2208 ∈ \u2209 ∉ \u220B ∋ \u220F ∏
\u2211 ∑ \u2212 − \u2217 ∗ \u221A √
\u221D ∝ \u221E ∞ \u2220 ∠ \u2227 ∧ \u2228 ∨
\u2229 ∩ \u222A ∪ \u222B ∫ \u2234 ∴ \u223C ∼
\u2245 ≅ \u2248 ≈ \u2260 ≠ \u2261 ≡ \u2264 ≤
\u2265 ≥ \u2282 ⊂ \u2283 ⊃ \u2284 ⊄ \u2286 ⊆
\u2287 ⊇ \u2295 ⊕ \u2297 ⊗ \u22A5 ⊥
\u22C5 ⋅ \u2308 ⌈ \u2309 ⌉ \u230A ⌊
\u230B ⌋ \u2329 ⟨ \u232A ⟩ \u25CA ◊
\u2660 ♠ \u2663 ♣ \u2665 ♥ \u2666 ♦
\x22 " \x26 & \x3C < \x3E > \u152 Œ
\u153 œ \u160 Š \u161 š \u178 Ÿ
\u2C6 ˆ \u2DC ˜ \u2002   \u2003   \u2009  
\u200C ‌ \u200D ‍ \u200E ‎ \u200F ‏ \u2013 –
\u2014 — \u2018 ‘ \u2019 ’ \u201A ‚
\u201C “ \u201D ” \u201E „ \u2020 †
\u2021 ‡ \u2030 ‰ \u2039 ‹ \u203A ›
\u20AC €
}
# H - take a connection and HTTP it
namespace eval H {
variable default_port 80
# corovar - used extensively to store state in the per-coro scope
proc corovar {n} {
uplevel 1 upvar #1 $n $n
}
variable Errors
array set Errors {
1 "Informational - Request received, continuing process"
100 Continue
101 "Switching Protocols"
2 "Success - received, understood, and accepted"
200 OK
201 Created
202 Accepted
203 "Non-Authoritative Information"
204 "No Content"
205 "Reset Content"
206 "Partial Content"
3 "Redirection - Further action needed"
300 "Multiple Choices"
301 "Moved Permanently"
302 "Found"
303 "See Other"
304 "Not Modified"
305 "Use Proxy"
307 "Temporary Redirect"
4 "Client Error - request bad or cannot be fulfilled"
400 "Bad Request"
401 "Unauthorized"
402 "Payment Required"
403 "Forbidden"
404 "Not Found"
405 "Method Not Allowed"
406 "Not Acceptable"
407 "Proxy Authentication Required"
408 "Request Time-out"
409 "Conflict"
410 "Gone"
411 "Length Required"
412 "Precondition Failed"
413 "Request Entity Too Large"
414 "Request-URI Too Large"
415 "Unsupported Media Type"
416 "Requested range not satisfiable"
417 "Expectation Failed"
5 "Server Error - Server failed to fulfill an apparently valid request"
500 "Internal Server Error"
501 "Not Implemented"
502 "Bad Gateway"
503 "Service Unavailable"
504 "Gateway Time-out"
505 "HTTP Version not supported"
}
# set the title <meta> tag, assuming we're returning fragment content
proc title {r title} {
if {[string length $title] > 80} {
set title [string range $title 0 80]...
}
dict set r -title $title
return $r
}
# sysPage - generate a 'system' page
proc sysPage {rsp title content} {
dict set rsp content-type "text/html"
set rsp [title $rsp $title]
dict set rsp -content "<H2>$title</H2>\n$content"
dict lappend rsp -headers "<STYLE type='text/css'>
html * { padding:0; margin:0; }
body * { padding:10px 20px; }
body * * { padding:0; }
body { font:small sans-serif; }
body>div { border-bottom:1px solid #ddd; }
h1 { font-weight:normal; }
h2 { margin-bottom:.8em; }
h2 span { font-size:80%; color:#666; font-weight:normal; }
h3 { margin:1em 0 .5em 0; }
table {
border:1px solid #ccc; border-collapse: collapse; background:white; }
tbody td, tbody th { vertical-align:top; padding:2px 3px; }
thead th {
padding:1px 6px 1px 3px; background:#fefefe; text-align:left;
font-weight:normal; font-size:11px; border:1px solid #ddd; }
tbody th { text-align:right; color:#666; padding-right:.5em; }
table.errorinfo { margin:5px 0 2px 40px; }
table.errorinfo td, table.dict td { font-family:monospace; }
#summary { background: #ffc; }
#summary h2 { font-weight: normal; color: #666; }
#errorinfo { background:#eee; }
#details { background:#f6f6f6; padding-left:120px; }
#details h2, #details h3 { position:relative; margin-left:-100px; }
#details h3 { margin-bottom:-1em; }
</style>"
return $rsp
}
# ErrorPage - given a Tcl error, generate a nice looking error page
proc ErrorPage {rsp error {eo ""}} {
set content ""
set tmessage ""
if {[catch {
if {$eo ne ""} {
append content "<H2>Error Code '[dict get $eo -errorcode]'</H2>"
catch {dict unset eo -errorcode}
append content "<pre>[armour [dict get $eo -errorinfo]]</pre>"
catch {dict unset eo -errorinfo}
append table <tbody>
foreach {n1 v1} [dict get $eo -errorstack] {
append table <tr> <td> $n1 </td> <td> [armour $v1] </td> </tr> \n
}
dict unset eo -errorstack
dict for {n v} $eo {
append table <tr> <td> $n </td> <td> <pre> [armour $v] </pre> </td> </tr> \n
}
append table </tbody>
append content <table class='errorinfo' $table </table> \n
}
catch {append content <p> "Caller: " <code> [armour [info level -1]] </code> </p>}
set error [armour $error]
catch {dict unset rsp expires}
if {[string length $error] > 80} {
set tmessage [string range $error 0 80]...
} else {
set tmessage $error
}
set result [list [tclarmour $content] [tclarmour $error] $tmessage]
} r1 eo1]} {
if {![info exists result]} {
set result [list [tclarmour $content] [tclarmour $error] $tmessage]
}
Debug.error {Recursive ServerError $r1 ($eo1) from '$error' ($eo)}
} else {
Debug.http {ServerError [dumpMsg $rsp 0]}
}
return $result
}
# contents may not be Cached
proc NoCache {rsp} {
dict set rsp cache-control "no-store, no-cache, must-revalidate, max-age=0, post-check=0, pre-check=0"; # HTTP/1.1
dict set rsp expires "Sun, 01 Jul 2005 00:00:00 GMT" ;# deep past
dict set rsp pragma "no-cache" ;# HTTP/1.0
catch {dict unset rsp -modified}
catch {dict unset rsp -depends}
return $rsp
}
# construct an HTTP response containing a server error page
proc ServerError {rsp message {eo ""}} {
Debug.error {Server Error: '$message' ($eo) [dumpMsg $rsp]} 2
dict set rsp -code 500
dict set rsp -rtype Error
dict set rsp -dynamic 1
dict set rsp -error $message ;# record the original error
dict set rsp -error_dict $eo
if {[llength [info commands ::errLog]]} {
::errLog add $rsp $message $eo
}
# format up the page
lassign [ErrorPage $rsp $message $eo] content message tmessage
# make this an x-system type page
set rsp [sysPage $rsp "Server Error: $tmessage" [subst {
<div id='summary'> $message </div>
<div id='errorinfo'> $content </div>
[tclarmour [dump $rsp]]
}]]
# Errors are completely dynamic - no caching!
return [NoCache $rsp]
}
proc NotAcceptable {rsp args} {
dict set rsp -code 406; return $rsp
}
# construct an HTTP PreconditionFailed response
proc PreconditionFailed {rsp} {
dict set rsp -code 412; return $rsp
}
# construct an HTTP Bad response
proc Bad {rsp message {code 400}} {
set rsp [sysPage $rsp "Bad Request" <p>$message</p>]
dict set rsp -code $code
return $rsp
}
# construct an HTTP NotImplemented response
proc NotImplemented {rsp {message ""}} {
if {$message eq ""} {
set message "This function not implemented"
}
set rsp [sysPage $rsp "Not Implemented" <p>$message</p>]
dict set rsp -code 501
return $rsp
}
# construct an HTTP response containing a server error page
proc ServerError {rsp message {eo ""}} {
Debug.error {Server Error: '$message' ($eo) $rsp} 2
dict set rsp -code 500
# format up the page
lassign [ErrorPage $rsp $message $eo] content message tmessage
# make this an x-system type page
set rsp [sysPage $rsp "Server Error: $tmessage" [subst {
<div id='summary'> $message </div>
<div id='errorinfo'> $content </div>
[tclarmour $rsp]
}]]
# Errors are completely dynamic - no caching!
return [NoCache $rsp]
}
# return the current time and date in HTTP format
proc Now {} {
return [clock format [clock seconds] -format {%a, %d %b %Y %T GMT} -gmt true]
}
variable te_encodings {chunked} ;# support these te_encodings
variable ce_encodings {gzip} ;# support these char encodings
# CharEncoding - determine the charset of any content
proc CharEncoding {r} {
# decode the content-type ... FIXME - I bet there's more decoding to be done
if {![dict exists $r content-type]} {
return $r
}
set charset [join [lassign [split [dict get $r content-type] \;] ctype] \;]
if {[string match "charset=*" $charset]} {
set charset [string trim [lindex [split [string tolower $charset] =] 1]]
} else {
set charset ""
}
switch -glob -- $ctype\;$charset {
"text/*;" {
# no charset defined by the request, use default
corovar def_charset; set dict set r -encoding $def_charset
}
"*;" {
# no charset specified
dict set r -encoding binary
}
"*/*;*" {
# client specified both ctype and charset
if {$charset ni [encoding names]} {
# send NotAcceptable? But how?
corovar socket; uplevel tailcall tx_$socket [H NotAcceptable $r]
}
}
}
dict set r -encoding $charset ;# record the encoding we've selected
return $r
}
# Tmpfile - create a temporary file with appropriate encodings
proc Tmpfile {R} {
# create a temp file to contain entity
corovar entitypath ;# path in which to create entities
set entity [file tempfile $entitypath]
chan configure $entity -translation binary ;# store it as we get it
# prepare output file for receiving chunks
if {[dict exists $R -te] && "gzip" in [dict get $R -te]} {
::zlib push inflate $entity ;# inflate it on the fly
chan configure $entity -translation binary
}
return $entity
}
# ChunkSize - return the next chunk size
proc ChunkSize {socket} {
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -translation [list crlf $tx_translation]
chan event $socket readable [info coroutine] ;# that will be this
yield ;# await next chunk size line
chan event $socket readable {} ;# turn off readable event
set chunksize 0x[gets $socket] ;# how many bytes to read?
chan configure $socket -translation [list $rx_translation $tx_translation]
return $chunksize
}
# Chunked - perform chunked entity reception
proc Chunked {r} {
corovar socket ;# connection to client
corovar todisk ;# the size at which we elect to leave entities on disk
corovar maxentity ;# maximum sized entity we will accept
set r [CharEncoding $r] ;# determine charset of content
# get size of next chunk
set chunksize [ChunkSize $socket] ;# how many bytes to read?
if {$chunksize <= 0} {return 0} ;# no more bytes to read
dict set r -entity [set entity [Tmpfile $r]] ;# get entity fd
set total 0 ;# total size of entity read so far
while {$chunksize > 0} {
if {$maxentity > 0 && ($total+$chunksize) > $maxentity} {
# 413 "Request Entity Too Large"
catch {chan close $entity}
uplevel tailcall tx_$socket [H Bad $r "Request Entity Too Large ($maxentity)"]
}
# prepare the socket for fcopy - stop reading and writing while fcopying
chan event $socket readable {}
set tx_event [chan event $socket writable]; chan event $socket writable {}
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -translation binary
# start the entity fcopy
chan copy $socket $entity -size $chunksize -command [info coroutine]
lassign [yieldm] bytes error ;# await completion of fcopy
incr total $bytes ;# keep track of total read
catch {
# reset socket to header config, having read the entity or failed
chan configure $socket -translation [list $rx_translation $tx_translation]
chan event $socket writable $tx_event ;# restart the writable event
}
if {[catch {chan eof $socket} eof] || $eof} {
uplevel tailcall tx_$socket [H Bad $r "EOF in entity"]
}
if {$bytes != $chunksize || $error ne ""} {
# detect socket closure ASAP in sending
uplevel tailcall tx_$socket [H Bad $r "error '$error' in entity"]
}
set chunksize [ChunkSize $socket] ;# how big is next chunk?
}
dict set r content-length $total
chan configure $socket -translation [list $rx_translation $tx_translation]
chan event $socket readable rx_$socket ;# restart reader loop
chan event $socket writable $tx_event ;# restart writer
Debug.entity {got chunked entity in $entity}
# at this point we have a complete entity in $entity file, it's already been ungzipped
# we need to process it somehow
if {$todisk == 0 || [chan tell size $epath] <= $todisk} {
# we don't want to have things on disk, or it's small enough to have in memory
# ??? How is entity encoded? - got to read it with encoding
chan configure $entity -encoding [dict get $r -encoding]
dict set r -entity [chan read $entity] ;# grab the entity
chan close $entity ;# close the entity fd
} else {
# leave some hints for Query file processing
chan seek $entity 0 ;# rewind entity to start
dict set r -entity $entity ;# this entity is an open fd ... how to know?
}
# read+parse more header fields - apparently this is possible with Chunked ... who knew?
dict merge r $r [Parse [Header $socket $r] $r]
return $r
}
# Entity - given an entity size, read it in.
proc Entity {r} {
corovar socket ;# socket for pipeline
corovar todisk ;# size at which we leave entities on disk
corovar maxentity ;# maximum sized entity we will accept
# straight 'entity follows header' with explicit length
set left [dict get $r content-length]
# enforce server limits on Entity length
if {$maxentity > 0 && $left > $maxentity} {
# 413 "Request Entity Too Large"
uplevel tailcall tx_$socket [H Bad $r "Request Entity Too Large" 413]
}
set r [CharEncoding $r] ;# determine charset of content
# decide whether to read to RAM or disk
if {$todisk > 0 && $left > $todisk} {
# this entity is too large to be handled in memory, write it to disk
# create a temp file to contain entity
dict set r -entity [set entity [Tmpfile $r]]
# prepare the socket for fcopy - stop reading and writing while fcopying
# configure fcopy as binary
chan event $socket readable {}
set tx_event [chan event $socket writable] ;# remember current tx event
chan event $socket writable {}
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -translation binary
# start the fcopy
chan copy $socket $entity -size $left -command [info coroutine]
lassign [yieldm] bytes error ;# await fcopy completion
# reset socket to header config, having read the entity or failed
catch {
chan configure $socket -encoding binary -translation [list $rx_translation $tx_translation]
chan event $socket writable $tx_event ;# restart the writer
}
if {[catch {chan eof $socket} eof] || $eof} {
uplevel tailcall tx_$socket [H Bad $r "EOF in entity"]
}
if {$error ne "" || $bytes != $left} {
# detect socket closure or eof in fcopy
uplevel tailcall tx_$socket [H Bad $r "error '$error' in entity"]
}
# at this point we have a complete entity in the open $entity file, it's already been ungzipped
# we need to process it somehow
chan seek $entity 0
} elseif {$left > 0} {
# load entity into memory
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -translation [list binary $tx_translation]
chan event $socket readable [info coroutine]
set entity ""
while {[string length $entity] < $left && ![chan eof $socket]} {
yield ;# wait for READ event
append entity [chan read $socket $left]
}
dict set r -entity $entity
# reset socket to header config, having read the entity
catch {
set tx_translation [lindex [chan configure $socket -translation] 1]
chan configure $socket -encoding binary -translation [list $rx_translation $tx_translation]
chan event $socket readable rx_$socket ;# restart the reader
}
if {[string length $entity] < $left} {
uplevel tailcall tx_$socket [H Bad $r "EOF in entity"]
}
# postprocess/decode the entity
if {[dict exists $r -te]
&& [dict exists $r -entity]
&& "gzip" in [dict get $r -te]
} {
dict set r -entity [::zlib inflate [dict get $r -entity]]
}
} else {
dict set r -entity ""
# the entity, length 0, is therefore already read
# 14.13: Any Content-Length greater than or equal to zero is a valid value.
}
return $r
}
# TransferEncoding - determine requested transfer encoding
# we only accept gzip ce_encoding
proc TransferEncoding {r} {
# rfc2616 4.3
# The presence of a message-body in a request is signaled by the
# inclusion of a Content-Length or Transfer-Encoding header field in
# the request's headers.
if {[dict exists $r transfer-encoding]} {
set te [dict get $r transfer-encoding]
# chunked 3.6.1, identity 3.6.2, gzip 3.5,
# compress 3.5, deflate 3.5
set tels {}; set te_params {}
variable te_encodings ;# te_encodings we support
foreach tel [split $te ,] {
set param [lassign [split $tel ";"] tel]
set tel [string tolower [string trim $tel]]
if {$tel ni $te_encodings} {
# can't handle a transfer encoded entity
# queue up error response (no caching)
uplevel tailcall tx_$socket [H NotImplemented $r "$tel transfer encoding"]
# see 3.6 - 14.41 for transfer-encoding
# 4.4.2 If a message is received with both
# a Transfer-EncodIing header field
# and a Content-Length header field,
# the latter MUST be ignored.
} else {
lappend tels $tel
dict set te_params $tel [split $param ";"]
}
}
dict set r -te $tels
dict set r -te_params $te_params
} elseif {[dict get $r -Header method] in {POST PUT}
&& ![dict exists $r content-length]
} {
# this is a content-length driven entity transfer
# 411 Length Required
uplevel tailcall tx_$socket [H Bad $r "Length Required" 411]
}
return $r
}
# rxForwards - see which forwards we trust
# optionally called as a post-parse phase filter
proc rxForwards {R} {
# trust x-forwarded-for if we get a forwarded request from
# a local ip (presumably local ip forwarders are trustworthy)
set forwards {}
if {[dict exists $R x-forwarded-for]} {
foreach xff [split [dict get? $R x-forwarded-for] ,] {
set xff [string trim $xff]
set xff [lindex [split $xff :] 0]
if {$xff eq ""
|| $xff eq "unknown"
|| [Http nonRouting? $xff]
} continue
lappend forwards $xff
}
}
dict set R -forwards $forwards
return $R
}
# rxLint - perform some careful checking on request header
# optionally called as a post-parse phase filter
proc rxLint {R} {
Debug.httpdlow {rxLint $R}
set headers [split [dict get $R -Header full]]
# ensure the HTTP method is acceptable
set method [string toupper [lindex $headers 0]]
dict set R -Header method $method
# ensure the HTTP method is acceptable
if {$method ni {GET PUT POST HEAD OPTIONS}} {
uplevel tailcall tx_$socket [H Bad $R "Method unsupported '$method'" 405]
}
# ensure the HTTP version is acceptable
if {[dict get $R -Header version] ni {1.1 1.0}} {
# Send 505 for protocol != HTTP/1.0 or HTTP/1.1
corovar id
uplevel tailcall tx_$socket [H Bad $R [list -transaction $transaction] "HTTP Version '[dict get $R -Header version]' not supported" 505]
}
# ensure the URI is plausible
set uri [dict get $R -Header uri]
corovar maxurilen
if {$maxurilen && [string length $uri] > $maxurilen} {
# send a 414 back
uplevel tailcall tx_$socket [H Bad $R [list -transaction $transaction] "URI too long '$uri'" 414]
}
return $R
}
# Support for x-www-urlencoded character mapping
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
variable dmap {%0D%0A \n %0d%0a \n %% %}
# set up non-alpha map
::apply [list {} {
variable dmap
for {set i 0} {$i < 256} {incr i} {
set c [format %c $i]
lappend dmap %[format %.2X $i] [binary format c $i]
lappend dmap %[format %.2x $i] [binary format c $i]
}
} [namespace current]]
# decode - decode data in www-url-encoded format.
proc decode {str} {
variable dmap
set str [string map $dmap $str]
set str [encoding convertfrom utf-8 $str]
return $str
}
# normalize - strip redundant and potentially damaging path elements from path
proc normalize {url} {
while {[set new [regsub -all {(/+)|(^[.][.]/)|(^/[.][.])|(/[^/]+/[.][.]$)|(/[^/]+/[.][.]/)|(^[.]/)|(/[.]$)|(/[.]/)|(^[.][.]$)|(^[.]$)} $url /]] ne $url} {
set url $new
}
return "/[string trimleft $url /]"
}
# path- parse a url path+fragment+query into its constituent parts
proc path {url} {
array set x {}
regexp {^([^?\#]*)([?]([^\#]*))?(\#(.*))?$} $url -> x(path) . x(query) . x(fragment)
set x(path) [normalize [decode $x(path)]] ;# fix up oddities in URLs
foreach n [array names x] {
if {$x($n) eq ""} {
unset x($n)
}
}
return [array get x]
}
proc url {args} {
if {[llength $args] == 1} {
set args [lindex $args 0]
}
if {![dict exists $args scheme]} {
dict set args scheme http ;# need a default.
}
# minimize port
if {[dict exists $args port]} {
if {[dict get $args port] eq ""} {
dict unset args port
} elseif {[dict get $args scheme] eq "http" && [dict get $args port] eq "80"} {
dict unset args port
} elseif {[dict get $args scheme] eq "https" && [dict get $args port] eq "443"} {
dict unset args port
} elseif {[dict get $args scheme] eq "ftp" && [dict get $args port] eq "21"} {
dict unset args port
}
}
foreach {part pre post} {
scheme "" :/
host / ""
port : ""
path "" ""
} {
if {[dict exists $args $part]} {
append result "${pre}[dict get $args $part]${post}"
}
}
return $result
}
proc parse_url {url} {
array set x {}
regexp {^(([^:/?\#]+):)?(//([^/?\#]*))?([^?\#]*)([?]([^\#]*))?(\#(.*))?$} $url \
-> . x(scheme) . x(authority) x(path) . x(query) . x(fragment)
regexp {^(([^@]+)@)?([^@:]+)?(:([0-9]+))?$} $x(authority) \
-> . x(authority) x(host) . x(port)
set x(path) [normalize [decode $x(path)]] ;# fix up oddities in URLs
foreach n [array names x] {
if {$x($n) eq ""} {
unset x($n)
}
}
if {[info exists x(host)]} {
# clean up host - check its validity?
set x(host) [string tolower $x(host)]
}
if {[info exists x(scheme)]} {
# clean up scheme - check its validity?
set x(scheme) [string tolower $x(scheme)]
} else {
set x(scheme) http
}
if {[info exists x(scheme)]} {
set x(url) [url [array get x]]
} else {
#set x(scheme) http
}
return [array get x]
}
# host - construct the host part of a URL dict
proc host {x} {
if {[dict exists $x port]
&& [dict get $x port] ne ""
&& [dict get $x port] != 80} {
return [dict get $x host]:[dict get $x port]
} else {
return [dict get $x host]
}
}
# Parse - given a set of header lines, parse them and populate the request dict
proc Parse {lines r} {
Debug.httpdlow {Parse: ($lines)}
# parse the first header line into its constituents
set lines [lassign $lines header]; dict set r -Header full $header
set headers [split $header]
# get version - needed for some protocol decisions
set version [lindex $headers end]
if {[string match HTTP/* $version]} {
set version [lindex [split $version /] 1]
}
dict set r -Header version $version ;# may as well stick it in the -Header
# parse the header lines into named fields in $r
foreach line $lines {
if {[string index $line 0] in {" " "\t"}} {
dict append r $key " [string trim $line]" ;# continuation line
} else {
set value [join [lassign [split $line ":"] key] ":"]
set key [string tolower [string trim $key "- \t"]]
if {[dict exists $r $key]} {
dict append r $key ",$value" ;# duplicate header - delimit with comma
} else {
dict set r $key [string trim $value] ;# new header
dict lappend r -clientheaders $key ;# keep list of headers passed in by client
}
}
# limit size of each field
corovar maxfield
if {$maxfield && [string length [dict get $r $key]] > $maxfield} {
uplevel tailcall tx_$socket [H Bad $r "Illegal header: '$key' is too long"]
}
}
# rfc2616 14.10:
# A system receiving an HTTP/1.0 (or lower-version) message that
# includes a Connection header MUST, for each connection-token
# in this field, remove and ignore any header field(s) from the
# message with the same name as the connection-token.
#### I have no idea what this is for
if {$version < 1.1 && [dict exists $r connection]} {
foreach token [split [dict get $r connection] ","] {
catch {dict unset r [string trim $token]}
}
dict unset r connection
}
set uri [join [lrange $headers 1 end-1]]; dict set r -Header uri $uri
if {[dict exists $r host]} {
# client sent Host: field
if {[string match http*:* $uri]} {
# absolute Host: field
# rfc 5.2 1 - a host header field must be ignored
# if request-line specified an absolute URL host/port
dict set r -Url [dict merge [dict get $r -Url] [parse_url $uri]]
} else {
# no absolute URL was specified on the request-line
# use the Host field to determine the host
lassign [split [dict get $r host] :] h p
dict set r -Url host $h
if {$p eq ""} {
dict set r -Url port $port
} else {
dict set r -Url port $p
}
dict set r -Url [dict merge [dict get $r -Url] [path $uri]]
}
} elseif {$version > 1.0} {
uplevel tailcall tx_$socket [H Bad $r "HTTP 1.1 required to send Host"]
} else {
# HTTP 1.0 isn't required to send a Host field
# but we still need host info as provided by Listener
dict set r -Url [dict merge [dict get $r -Url] [path $uri]]
dict set r -Url host [host [dict get $r -Url]]
}
# move-aside/rename fields whose names are the same in request/response
foreach n {cache-control pragma} {
if {[dict exists $r $n]} {
dict set r -$n [dict get $r $n]
dict unset r $n
}
}
if {0} {
#### could be done where it's used, if it's used
# remove 'netscape extension' length= from if-modified-since
if {[dict exists $r if-modified-since]} {
dict set r if-modified-since [lindex [split [dict get $r if-modified-since] {;}] 0]
}
}
# filter out all X-* form headers, move them to -x-* forms
# so we don't re-send them in reply
foreach x [dict keys $r x-*] {
dict set r -$x [dict get $r $x]
dict unset r $x
}
if {[dict exists $r etag]} {
# copy etag aside, so domains can provide their own
dict set $r -etag [dict get $r etag]
}
return $r
}
# Header - read header of request
proc Header {socket r} {
corovar maxheaders ;# maximum number of headers
corovar maxline ;# maximum header line length
corovar timeout ;# timout in mS
corovar timer ;# rx timer for timeout
chan configure $socket -blocking 0
if {[info exists timeout] && $timeout > 0} {
set timer [after $timeout [info coroutine] timeout]
}
set lines {}
while {![chan eof $socket]} {
set exception [::yield] ;# block until there's some input
if {$exception ne ""} {
return {} ;# we've timed out waiting - time to close up shop
} elseif {[info exists timer]} {
after cancel $timer
set timer [after $timeout [info coroutine] timeout]
}
set status [chan gets $socket line]
if {$status == -1} {
# we have no line - can we even get a line?
if {$maxline && [chan pending input $socket] > $maxline} {
Debug.httpd {[info coroutine] MAXLINE [chan pending input $socket] > $maxline}
uplevel tailcall tx_$socket [H Bad $r "Line too long (over $maxline)"]
}
continue
} elseif {!$status} {
# no input left to get
if {[llength $lines] > 0} {
Debug.httpdlow {[info coroutine] got [llength $lines] lines of header}
return $lines
}
} else {
Debug.httpdlow {[info coroutine] status $status '$line' - in:[chan pending input $socket] out:[chan pending output $socket]}
lappend lines $line ;# append all lines in header
}
}
return $lines ;# we got EOF - maybe we still have lines
}
# rxCORS - respond to CORS request with
proc rxCORS {r} {
if {[dict get $r -Header method] eq "OPTIONS"
&& [dict exists $r access-control-request-method]} {
# simplistic CORS response
dict set r access-control-allow-origin *
dict set r access-control-allow-methods "POST, GET, OPTIONS"
dict set r access-control-max-age 1000
dict set r access-control-allow-headers *
dict set r -code 200
#tx_$socket $r ;# send the CORS response
return -code return $r ;# no more processing
}
}
# rxEntity - read entity from $socket
# could be run from Process rather than Reader
proc rxEntity {r} {
# fetch the entity (if any)
set r [TransferEncoding $r]
if {[dict exists $r -te]
&& "chunked" in [dict get $r -te]
} {
set r [Chunked $r]
} elseif {[dict exists $r content-length] && [dict get $r content-length]} {
set r [Entity $r]
}
return $r
}
# Pre-Process the request:
# Run all the $pre commands - ignoring errors, but permitting them usurp the process
# return - the pre-process has decided to overrule process
# continue - the pre-process has nothing to add
# break - the pre-process says continue straight to Process
# error - the pre-process failed - skip it
# ok - the preprocess has modified the request
proc Pre {r pre} {
foreach P $pre {
Debug.httpd {TRY pre '$P'}
try {
uplevel 1 [list {*}$P $r]
} on return {r} {
# the pre-process has decided to usurp processing
Debug.httpd {pre '$P' - the pre-process has decided to usurp processing}
tailcall tx_$socket $r
} on continue {} {
Debug.httpd {pre '$P' - the pre-process has nothing to add}
# the pre-process has nothing to add
} on break {r} {
Debug.httpd {pre '$P' - the pre-process says skip the rest of the pre-processes}
# the pre-process says skip the rest of the pre-processes,
# continue with the process
break
} on error {e eo} {
Debug.httpd {pre '$P' - the pre-process has failed '$e' ($eo)}
# the pre-process failed - skip it
} on ok {r} {
# the preprocess returned a response, consume it
Debug.httpd {pre '$P' - the pre-process has returned a response ($r)}
}
}
return $r
}
proc Process {r process error} {
# Process request: run the $process command
# continue - process has nothing to add to pre-processing
# break - the process will handle its own response transmission
# error - the process has errored - make a ServerError response
# ok - the process has returned its reply
Debug.httpd {TRY process '$process'}
try {
#uplevel 1 [list {*}$process $r]
{*}$process $r
} on error {e eo} {
# the process errored out - send an error message
Debug.httpd {process '$process' - the process has failed '$e' ($eo)}
set r [{*}$error $r $e $eo]
} on continue {} {
# the process has nothing to say, post process
Debug.httpd {process '$process' - the process has nothing to say}
} on break {e eo} {
# the process will handle its own response
Debug.httpd {process '$process' - the process will handle its own response}
return -level 1 -options $eo $r
} on ok {r} {
# the process returned a response, post-process then send it
Debug.httpd {process '$process' - the process returned ($r)}
}
return $r
}
# Post-Process the response:
# Run all the $post commands - ignoring errors, but permitting them usurp the process
# return - the post-process has returned a reply, use it, skip the rest of post-processing
# continue - the post-process has nothing to add, continue with post-processing
# break - the post-process says skip the rest of post-processing, it will handle its own reply
# error - the post-process failed - skip it
# ok - the post-process has modified the request, consume it and continue post-processing
proc Post {r post} {
foreach P $post {
try {
uplevel 1 [list {*}$P $r]
} on break {e eo} {
# the post-process says skip the rest of the post-processes,
# it will handle its own response
return -level 2 -options $eo $r
} on continue {} {
# the post-process has nothing to add
} on error {e eo} {
# the pre-process failed - skip its contribution
} on return {r} {
# the post-process says skip the rest of the post-processes but return its result
break
} on ok {r} {
# the preprocess returned a response, consume it
}
}
return $r
}
proc defaults {string} {
set defaults {}
foreach line [split [uplevel [list subst $string]] \n] {
if {[string trim $line] eq ""} continue
lassign [split $line \;] line
lappend defaults {*}[string trim $line]
}
upvar 1 args a
set a [dict merge $defaults $a]
}
# rxBlock - simple blocker on socket characteristics
proc rxBlock {} {}
# RX - coroutine to process pipeline reception
proc RX {args} {
# all of these variables become corovars
defaults {
port 80 ;# default listening port
maxline 4096 ;# maximum line length we'll accept
maxline 4096 ;# maximum header line length
maxheaders 200 ;# maximum number of headers we'll accept
maxurilen 0 ;# maximum length of URI
maxfield 0
maxentity 0
todisk 0
block {}
parsed {rxLint rxEntity}
pre {}
process process
post {}
error {H ServerError} ;# command prefix to translate errors
def_charset [encoding system]
entitypath "" ;# path on which Tmpfile creates entity files
opts {}
timeout 60000 ;# one minute timeout on open connections
}
# all of these variables become corovars
dict with args {}
if {[dict exists $args r]} {
dict unset args r ;# $r is used a lot below
}
Debug.httpd {start RX [info coroutine] $args}
# ensure there's a viable entity path
if {$entitypath ne ""} {
set entitypath [file normalize $entitypath]
dict set args entitypath $entitypath
file mkdir [file dirname $entitypath]
}
if {[llength $block]} {
{*}$block ;# block connection according to source
}
# put receiver into header/CRLF mode and start listening for readable events
set tx_translation [lindex [chan configure $socket -translation] 1]
chan configure $socket -blocking 1 -translation [list crlf $tx_translation]
chan event $socket readable [info coroutine]
set transaction 0 ;# unique count of packets received by this receiver
while {![chan eof $socket]
|| [chan pending input $socket] != -1
|| [chan pending output $socket] != -1
} {
set R [list -socket $socket -transaction [incr transaction]]
set headers [Header $socket $R] ;# collect the header
if {![llength $headers]} break ;# timed out
set R [Parse $headers $R] ;# $headers is a complete request header
set R [Pre $R $parsed] ;# run some post-parsing
chan event $socket readable {} ;# stop the reader
# NB: stop reading here so that the configuration can decide when/how/whether to read entities
# indicate to tx that a request with this transaction id
# has been received and is (as yet) unsatisfied
tx_$socket [list -transaction $transaction] ;# is this even necessary?
# Process the request in a bespoke coroutine
if {[llength [info commands process.$socket]]} {
Debug.httpd {Starting process process.socket}
process.$socket $R
} else {
coroutine process.$socket.$transaction ::apply [list {r socket pre process post error} {
Debug.httpd {Starting process [info coroutine]}
set r [Pre $r $pre] ;# pre-process the request
set r [Process $r $process $error] ;# process the request
set r [Post $r $post] ;# post-process the request
tailcall tx_$socket $r ;# finally, transmit the response
if {[dict exists $r connection]
&& [string tolower [dict get $r connection]] eq "close"} {
chan close $socket read
}
} [namespace current]] $R $socket $pre $process $post $error
}
}
if {[info exists timer]} {
catch {after cancel $timer}
}
Debug.httpd {RX END}
}
# WantGZIP? do we want to gzip this content?
proc WantGZIP? {reply} {
variable ce_encodings ;# what encodings do we support?
if {[dict exists $reply content-range]} {
return 0 ;# can't handle gzipped content-range
}
set ct [dict get $reply content-type]
if {"gzip" ni $ce_encodings
|| [string match image/* $ct]
|| [string match binary/* $ct]
} {
return 0 ;# we somewhat arbitrarily refuse to zip binary content
}
# choose content encoding
if {[dict exists $reply accept-encoding] && ![dict exists $reply content-encoding]} {
foreach en [split [dict get $reply accept-encoding] ","] {
lassign [split $en ";"] en pref
set en [string trim $en]
if {$en in $ce_encodings} {
switch $en {
"gzip" {
return 1
}
}
}
}
}
return 0
}
# CE - find and effect appropriate content encoding
proc CE {reply args} {
if {![WantGZIP? $reply]} {
return $reply
}
set content [dict get $reply -content]
# prepend a minimal gzip file header:
# signature, deflate compression, no flags, mtime,
# xfl=0, os=3
set gztype [expr {[string match text/* [dict get $reply content-type]]?"text":"binary"}]
set gzip [::zlib gzip $content -header [list crc 0 time [clock seconds] type $gztype]]
if {[string length $gzip] < [string length $content]} {
dict set reply -content $gzip
dict set reply content-encoding gzip
}
return $reply ;# this reply now contains gzipped content
}
# Charset - ensure correctly encoded content in response
proc Charset {reply} {
if {[dict exists $reply -chconverted]} {
return $reply ;# don't re-encode by charset
}
# handle charset for text/* types
lassign [split [dict get $reply content-type] {;}] ct
if {[string match text/* $ct] || [string match */*xml $ct]} {
if {[dict exists $reply -charset]} {
set charset [dict get $reply -charset]
} else {
set charset [encoding system] ;# default charset (utf-8)
dict set reply -charset $charset
}
# ensure content is converted to correct charset,
# flag conversion in response, to avoid double conversion
dict set reply -chconverted $charset
dict set reply content-type "$ct; charset=$charset"
dict set reply -content [encoding convertto $charset [dict get $reply -content]]
}
return $reply
}
# find etag in if-range field
proc if-range {req etag} {
if {![dict exists $req if-range]} {
return 1
}
set etag \"[string trim $etag \"]\"
set im [split [dict get $req if-range] ","]
set result [expr {$im eq "*" || $etag in $im}]
Debug.cache {if-match: $result - $etag in $im}
return $result
}
# find etag in if-none-match field
proc any-match {req etag} {
if {![dict exists $req if-none-match]} {
return 0
}
set etag \"[string trim $etag \"]\"
set im [split [dict get $req if-none-match] ","]
set result [expr {$etag in $im}]
Debug.cache {any-match: $result - $etag in $im}
return $result
}
# find etag in if-match field
proc if-match {req etag} {
if {![dict exists $req if-match]} {
return 1
}
set etag \"[string trim $etag \"]\"
set im [split [dict get $req if-match] ","]
set result [expr {$im eq "*" || $etag in $im}]
Debug.cache {if-match: $result - $etag in $im}
return $result
}
# Conditional - make GET/HEAD conditional
# this will transform a request if there's a conditional which
# applies to it.
proc Conditional {r} {
if {![dict exists $r etag]} {
return $r
}
set etag [dict get $r etag]
# Check if-none-match
if {[H any-match $r $etag]} {
# rfc2616 14.26 If-None-Match
# If any of the entity tags match the entity tag of the entity
# that would have been returned in the response to a similar
# GET request (without the If-None-Match header) on that
# resource, or if "*" is given and any current entity exists
# for that resource, then the server MUST NOT perform the
# requested method, unless required to do so because the
# resource's modification date fails to match that
# supplied in an If-Modified-Since header field in the request.
if {[string toupper [dict get $r -Header method]] in {"GET" "HEAD"}} {
# if the request method was GET or HEAD, the server
# SHOULD respond with a 304 (Not Modified) response, including
# the cache-related header fields (particularly ETag) of one
# of the entities that matched.
Debug.cache {unmodified [dict get $r -uri]}
# the response MUST NOT include other entity-headers
# than Date, Expires, Cache-Control, Vary, Etag, Content-Location
set r [dict filter $r script {n v} {
expr {[string tolower $n] in {date expires cache-control vary etag content-location}}
}]
dict set r -code 304
return $r
} else {
# For all other request methods, the server MUST respond with
# a status of 412 (Precondition Failed).
#return [H PreconditionFailed $r]
}
} elseif {![H if-match $r $etag]} {
#return [H PreconditionFailed $r]
} elseif {![H if-range $r $etag]} {
catch {dict unset r range}
# 14.27 If-Range
# If the entity tag given in the If-Range header matches the current
# entity tag for the entity, then the server SHOULD provide the
# specified sub-range of the entity using a 206 (Partial content)
# response. If the entity tag does not match, then the server SHOULD
# return the entire entity using a 200 (OK) response.
}
return $r
}
# clf - common log format
# used to generate one form of log from a response dict
proc clf {r} {
lappend line [dict get $r -ipaddr] ;# remote IP
lappend line - ;# RFC 1413 identity of the client. 'sif
if {[dict exists $r -user]} {
# is there a user identity?
lappend line [dict get $r -user]
} else {
lappend line -
}
# receipt time of connection
lappend line \[[clock format [dict get $r -received_seconds] -format "%d/%b/%Y:%T %Z"]\]
# first line of request
lappend line \"[dict get $r -Header full]\"
# status we returned to it
if {[dict exists $r -code]} {
lappend line [dict get $r -code]
} else {
lappend line 200
}
# content byte length
if {[dict exists $r content-length]} {
lappend line [dict get $r content-length]
} else {
lappend line ""
}
# referer, useragent, cookie, if any
if {[dict exists $r referer]} {
lappend line \"[dict get $r referer]\"
} else {
lappend line \"\"
}
if {[dict exists $r user-agent]} {
lappend line \"[dict get $r user-agent]\"
} else {
lappend line \"\"
}
if {[dict exists $r -user]} {
lappend line \"[dict get $r -user]\"
} elseif {[dict exists $r cookie]} {
lappend line \"[dict get $r cookie]\"
}
if {[dict exists $r -received] && [dict exists $r -sent]} {
set diff [expr {[dict get $r -sent] - [dict get $r -received]}]
}
return [string map {\n \\n \r \\r} [join $line]]
}
# TxLine - send a line to the pipeline socket
proc TxLine {line} {
corovar socket
chan puts $socket $line
Debug.httpdtxlow {[info coroutine] TxLine: '$line'}
# FIXME: refrain from sending too-long lines
}
# txCookies - optional header generator for cookies
proc txCookies {socket reply} {
# add in any cookies already formatted up
if {[dict exists $reply set-cookie]} {
TxLine "set-cookie: [dict get $reply set-cookie]"
}
# format up and send each cookie
if {[dict exists $reply -cookies]} {
Debug.cookies {processing: [dict get $reply -cookies]}
set c [dict get $reply -cookies]
foreach cookie [Cookies format4server $c] {
Debug.cookies {set-cookie: '$cookie'}
TxLine "set-cookie: $cookie"
}
}
}
# txAuth - optional header generator for -auth
proc txAuth {socket reply} {
# add in Auth header elements - TODO
foreach challenge [dict get? $reply -auth] {
TxLine "WWW-Authenticate: $challenge"
}
}
# set of request-only headers
variable rq_headers {
accept accept-charset accept-encoding accept-language authorization
expect from host if-match if-modified-since if-none-match if-range
if-unmodified-since max-forwards proxy-authorization referer te
user-agent keep-alive cookie via range
origin sec-websocket-key1 sec-websocket-key2
access-control-request-method
}
proc TX {args} {
# create corovars from $args with defaults
defaults {
log "" ;# log file (default none)
log_command {H clf} ;# default event log generator
server_id "Wub [package present H]"
header {} ;# commands to add headers
opts {}
}
dict with args {}
Debug.httpd {start TX [info coroutine]}
# get socket set into header (crlf) mode
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -blocking 0 -buffering line -translation [list $rx_translation crlf]
set pending {} ;# dict of requests pending responses
set sent 0 ;# how many contiguous packets have we sent?
# while the channel is still open for transmission
while {[chan pending output $socket] != -1} {
set r [yield]
if {[dict exists $r -code] && [dict get $r -code] == 100} {
# special case 100-Continue - straight out the socket
Debug.httpd {[info coroutine] TX sending 100 Continue}
TxLine "HTTP/1.1 100 Continue"
TxLine ""
continue
}
# Initial reception of a request is signalled by a mostly-empty dict
# we get the -transaction, being the ordinal number of received requests
if {![dict exists $r -transaction]} {
#puts stderr "ANOMALY: ($r)"
puts stderr "ANOMALY: ($r) [info frame]"
#for {set f 0} {$f <= [info frame]} {incr f} {
#puts stderr "F$f: [info frame $f]"
#}
continue
}
set trx [dict get $r -transaction]; dict unset r -transaction
if {[dict size $r] == 0} {
Debug.httpd {[info coroutine] TX received indication of $trx reception}
continue ;# keep waiting for content to send
# FIXME: what if we get a received $trx indication out of sequence?
}
if {$trx <= $sent} {
# duplicate of an already-sent packet
# this could happen if a processing command has sent us
# multiple responses. First one wins, fellers.
Debug.error {Send discarded: duplicate ([H $r])}
continue
} elseif {
[dict exists $pending $trx]
&& [dict size [dict get $pending $trx]]
} {
# a duplicate response has been sent - discard this
# this could happen if a dispatcher sends a response,
# and subsequently gets an error which we try to send out
Debug.error {Send discarded: duplicate ([H $r]) - sent:([H [dict get $pending $trx]])}
continue ;# duplicate response - just ignore
}
dict set pending $trx $r ;# accept the pending response
# received a response - process all pending responses.
# requests are stored in order of reception, so we process in
# natural key order. Thank you dkf for that ability.
foreach next [dict keys $pending] {
if {$next > $sent+1} {
Debug.httpd {[info coroutine] TX exhausted $next ([dict size $pending] remain)}
break ;# pipeline is blocked
}
# respond to the next transaction in trx order
# consume the next reply from pending queue
set reply [dict get $pending $next]
if {![dict size $reply]} {
Debug.httpd {[info coroutine] TX pipeline stalled on $next}
break ;# merely a place-holder. We must wait for the actual packet
}
dict unset pending $next ;# consume pending response
Debug.httpd {[info coroutine] TX sending ($reply)}
# ensure the reply code is set
if {![dict exists $reply -code]} {
dict set reply -code [set code 200] ;# presume it's ok
} elseif {[set code [dict get $reply -code]] < 4} {
# presume this was a tcl error code, not an HTTP code
Debug.httpd {[info coroutine] TX Tcl error code ($code)}
dict set reply -code [set code 500]
}
# make reply conditional if requested
if {$code eq 200} {
# non-OK responses aren't conditional (?)
set reply [Conditional $reply]
set code [dict get $reply -code]
}
# handle Vary field and -vary dict
dict set reply -vary Accept-Encoding 1
if {[dict exists $reply -vary]} {
if {[dict exists $reply -vary *]} {
dict set reply vary *
} else {
dict set reply vary [join [dict keys [dict get $reply -vary]] ,]
}
dict unset reply -vary
}
# set the informational header error message
if {[dict exists $reply -error]} {
set errmsg [dict get $reply -error]
}
if {![info exists errmsg] || ($errmsg eq "")} {
variable Errors
if {[info exist Errors($code)]} {
set errmsg $Errors($code)
} else {
set errmsg "Error $code"
}
}
### send header down the socket
TxLine "HTTP/1.1 $code $errmsg"
TxLine "Date: [Now]"
TxLine "Server: $server_id"
# Deal with content data by response type
set range {} ;# default no range
if {$code == 204} {
# 204 (no content),
# responses MUST NOT include a message-body
foreach n [dict keys $reply content-*] {
dict unset reply $n
}
foreach n {transfer-encoding} {
if {[dict exists $reply $n]} {
dict unset $reply $n
}
}
} elseif {$code >= 200 && $code < 300} {
# handle range for 200
if {[dict exists $reply range]} {
set ranges [dict get $reply range] ;# client requested a range of content
# FIXME: multiple Range - this only does one
# FIXME: what about transfer-encoded (ie: gzipped) content?
# FIXME: what about a range over a file?
Debug.httpd {ranges: $ranges}
set ranges [lindex [lassign [split $ranges =] unit] 0]
set ranges [split $ranges ,]
set ranges [lindex $ranges 0] ;# only handle one range
foreach rr $ranges {
lassign [split $rr -] from to
lassign [split $to] to
set size [dict get $reply content-length]
if {$from eq ""} {
set from [expr {$size-$to+1}]
set to $size
} elseif {$to > $size || $to eq ""} {
set to [expr {$size-1}]
}
lappend range $from $to ;# remember range to send
}
# send appropriate content range and length fields
set code 206 ;# partial content
dict set reply content-range "bytes $from-$to/$size"
dict set reply content-length [expr {$to-$from+1}]
Debug.httpd {range: [dict get $reply content-range] of length [dict get $reply content-length]}
}
}
if {$code == 204 || [dict get $reply -Header method] eq "HEAD"} {
# All responses to the HEAD request method MUST NOT
# include a message-body but may contain all the content
# header fields.
if {![catch {dict unset $reply -content}]} {
# remove any vestige of content
} elseif {[dict exists $reply -file]} {
# we have a -file - must close it
catch {chan close [dict get $reply -file]}
dict unset reply -file
}
}
catch {dict unset reply transfer-encoding} ;# default not chunked
catch {dict unset reply content-encoding} ;# default not gzipped
if {[dict exists $reply -content]} {
set reply [Charset $reply] ;# charset-encode content
if {[WantGZIP? $reply]} {
# gzip it right now - prepend a minimal gzip file header:
# signature, deflate compression, no flags, mtime,
# xfl=0, os=3
set gztype [expr {[string match text/* [dict get $reply content-type]]?"text":"binary"}]
set gzip [::zlib gzip [dict get $reply -content] -header [list crc 0 time [clock seconds] type $gztype]]
if {[string length $gzip] < [string length [dict get $reply -content]]} {
# don't send gzipped if it is larger
dict set reply -content $gzip
dict set reply content-encoding gzip
}
}
dict set reply content-length [string length [dict get $reply -content]] ;# set correct content-length
} elseif {[dict exists $reply -file]} {
# the app has returned an open file instead of literal content
set fd [dict get $reply -file]
if {[catch {chan seek $fd 0}]} {
# this file is not seekable, it's a pure stream
catch {dict unset reply content-length} ;# this is a pipe, not a seekable file
dict set reply transfer-encoding chunked ;# it has to be sent chunked
if {[WantGZIP? $reply]} {
# we're going to gzip this thing ... we con't know its length
dict set reply content-encoding gzip
}
} elseif {[WantGZIP? $reply]} {
# we're going to gzip this thing ... we won't know its length, we're at the start
dict set reply content-encoding gzip
dict set reply transfer-encoding chunked ;# it has to be sent chunked
catch {dict unset reply content-length} ;# this is a pipe, not a seekable file
} elseif {![dict exists $reply content-length]} {
# not gzipping, is seekable - can/should know its length
chan seek $fd 0 end ;# move back to the start of the file
dict set reply content-length [chan tell $fd]
chan seek $fd 0
} else {
# we're at the start, we have been given the length
}
} else {
Debug.error {Format: contentless - response empty - no content in reply ($reply)}
dict set reply content-length 0 ;# no -content, no -file ... must be of length 0
}
# send all HTTP fields which have relevance in response
variable rq_headers
dict for {n v} $reply {
if {[string index $n 0] eq "-"} continue
set nl [string tolower $n]
if {[string match x-* $nl]} {
TxLine "$n: $v"
} elseif {$nl ni $rq_headers} {
TxLine "$n: $v"
}
}
# send optional HTTP fields via code specified in $header
foreach P $header {
catch {
{*}$P $socket $reply
}
}
# connection close after transmission required?
# NB: we only consider closing if all pending requests
# have been satisfied.
if {[dict exists $reply -close] && [dict get $reply -close]} {
# inform client of intention to close
Debug.httpd {[info coroutine] close requested on $socket - sending header}
TxLine "Connection: close" ;# send a close just in case
# Once this header's been sent, we're committed to closing
}
TxLine "" ;# send end-of-header
# set the tx socket up for entity transmission - binary
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -buffering none -translation [list $rx_translation binary]
# send the content/entity (if any)
# note: we must *not* send a trailing newline, as this
# screws up the content-length and confuses the client
# which doesn't then pick up the next response
# in the pipeline
if {[dict exists $reply -file]} {
# send content of file descriptor using fcopy
Debug.httpd {[info coroutine] TX FCOPY}
set fd [dict get $reply -file]
# turn off any fileevents on the relevant file descriptors
set fd_readable [chan event $fd readable]; chan event $fd readable {}
set fd_writable [chan event $fd writable]; chan event $fd writable {}
set rx_event [chan event $socket readable]; chan event $socket readable {}
set tx_event [chan event $socket writable]; chan event $socket writable {}
if {[llength $range]} {
# process file content as a range
lassign $range from to
chan seek $fd $from
set size [expr {$to-$from+1}]
Debug.httpd {[info coroutine] TX FCOPY RANGE: '$file' bytes $from-$to/$size}
chan copy $fd $socket -size $size -command [info coroutine] ;# start the copy
} else {
# send entire file
Debug.httpd {[info coroutine] TX FCOPY ENTITY: '$file'/$fd $bytes bytes}
chan copy $fd $socket -command [info coroutine] ;# start the copy
}
lassign [yieldm] bytes error ;# wait for the chan copy to finish
if {$error ne ""} {
# detect socket closure or eof in fcopy
Debug.error {[info coroutine] tx FCOPY FAILED: $bytes $error}
return ;# we're done now
}
# reset socket to header config, having read the entity or failed
chan configure $socket -encoding binary -translation [list $rx_translation $tx_translation]
chan event $socket readable $rx_event ;# restart the reader
} elseif {[llength $range]} {
# send literal content range
lassign $range from to
chan puts -nonewline $socket [string range [dict get $reply -content] $from $to]
Debug.httpd {[info coroutine] TX SENT RANGE: LITERAL bytes $from-$to/[string length [dict get $reply -content]] bytes}
} elseif {[dict exists $reply -content] && [string length [dict get $reply -content]]} {
# send literal content entire
chan puts -nonewline $socket [dict get $reply -content] ;# send the content
Debug.httpd {[info coroutine] TX SENT ENTITY: [string length [dict get $reply -content]] bytes}
} else {
# no content to send, for some reason
Debug.httpd {[info coroutine] TX NO CONTENT}
}
chan flush $socket
# set the tx socket up for header sending - crlf
lassign [chan configure $socket -translation] rx_translation tx_translation
chan configure $socket -buffering none -translation [list $rx_translation crlf]
# this request is no longer pending
Debug.httpd {[info coroutine] TX SENT $sent}
incr sent ;# advance lower edge of transmission window
# generate a log line
if {$log ne "" && [catch {
chan puts $log [{*}$log_command $reply] ;# generate a log line
chan flush $log
} le leo]} {
Debug.error {log error: $le ($leo)}
}
}
}
}
# pipeline - this is where the action happens
proc Pipeline {opts socket ipaddr rport} {
Debug.listener {Pipeline $opts $socket $ipaddr $rport}
set rx [list ipaddr $ipaddr rport $rport {*}$opts socket $socket]
if {[dict exists $opts rx]} {
set rx [dict merge $rx [dict get $opts rx]]
dict unset opts rx
}
set tx $rx
if {[dict exists $opts tx]} {
set tx [dict merge $tx [dict get $opts tx]]
dict unset opts tx
}
dict with opts {}
if {[info exists tls]} {
# do something with TLS
package require tls
set tls [dict merge {
-certfile server-public.pem
-keyfile server-private.pem
-cadir .
-cafile ca.pem
-ssl2 0
-ssl3 1
-tls1 1
-require 0
-request 1} $tls]
tls::import $socket {*}$tls ;# graft the TLS connection on socket
tls::handshake $socket ;# start the TLS handshake
}
# create a coro for rx one for tx, arrange for the socket to close respective half on termination
::coroutine rx_$socket [namespace current] RX {*}$rx
trace add command [namespace current]::rx_$socket delete [list ::apply {{s args} {catch {chan close $s read}}} $socket]
::coroutine tx_$socket [namespace current] TX {*}$tx
trace add command [namespace current]::tx_$socket delete [list ::apply {{s args} {catch {chan close $s write}}} $socket]
}
# listen on nominated port
proc listen {args} {
if {[llength $args]%2} {
set port [lindex $args end]
set args [lrange $args 0 end-1]
} elseif {[dict exists $args port]} {
set port [dict get $args port]
} else {
variable default_port; set port $default_port
}
# start the listener
Debug.listener {server listening (Pipeline $args) [dict filter $args key -*] $port}
return [::socket -server [list [namespace current] Pipeline $args] {*}[dict filter $args key -*] $port]
}
namespace export -clear *
namespace ensemble create -subcommands {}
}
if {[info exists argv0] && ($argv0 eq [info script])} {
# Unit tests
puts stderr "[package present H] Unit Tests"
#Debug on httpd
#Debug on listener
#Debug on httpdlow
#Debug on httpdtxlow
#Debug on entity
Debug define cache
Debug define cookies
interp bgerror {} [list ::apply {{args} {
puts stderr "*******BGERROR: $args"
incr ::forever
}}]
package require tcltest
namespace import ::tcltest::*
package require http
set port 8080
set maxports 500
set verbose 0
variable {*}$argv
set phase 0
# construct an HTTP Ok response
proc Ok {rsp {content ""} {ctype ""}} {
if {[dict exists $rsp -code]} {
set code [dict get $rsp -code]
} else {
set code 200
}
if {$content ne ""} {
dict set rsp -content $content
} elseif {![dict exists $rsp -content]} {
dict set rsp content-length 0
}
if {$ctype ne ""} {
dict set rsp content-type $ctype
} elseif {![dict exists $rsp content-type]} {
dict set rsp content-type "text/html"
}
dict set rsp -code $code
return $rsp
}
variable SETUP {set listener [H listen process [list ::apply {{r} {Ok $r <p>Moop</p> text/html}}] $::port]}
variable CLEANUP {chan close $listener}
configure -verbose $verbose
skip unsupported-*
skip simple-*
#skip multi-*
proc get_test {token} {
set d {}
catch {set d [::http::meta $token]}
catch {dict set d -code [::http::ncode $token]}
catch {dict set d -status [::http::status $token]}
catch {dict set d -content [::http::data $token]}
catch {dict set d -error [::http::error $token]}
catch {dict set d -http [::http::code $token]}
return $d
}
proc test_dict {token args} {
if {[llength $args] == 1} {
set args [lindex $args 0]
}
set r {}
foreach {n v} [get_test $token] {
set n [string tolower $n]
if {[dict exists $args $n]} {
if {![string match [dict get $args $n] $v]} {
dict set r $n $v
}
dict unset args $n
}
}
::http::cleanup $token
return $r
}
set phase 0
# perform tests in event space
after 0 {::apply {{} {
puts stderr Phase:$::phase
set listener [H listen process [list ::apply {{r} {
Ok $r <p>Moop</p> text/html
}}] $::port]
test simple-GET {} -body {
variable port
set token [::http::geturl http://localhost:$::port/ -timeout 100]
::http::wait $token
test_dict $token {
-code 200
connection close
content-type {text/html; charset=utf-8}
server {Wub *}
vary Accept-Encoding
content-length 11
}
}
chan close $listener
set listener [H listen process [list ::apply {{r} {
expr 1/0 ;# provoke an error
}}] $::port]
test simple-ERROR {} -body {
variable port
set token [::http::geturl http://localhost:$::port/ -timeout 100]
::http::wait $token
test_dict $token {
-http {HTTP/1.1 500 Internal Server Error}
content-type {text/html; charset=utf-8}
}
}
chan close $listener
incr ::phase ;# move to next testing phase
}}}
vwait phase ;# wait for this testing phase to finish
# the tests need to be in event space
after 0 {::apply {{} {
puts stderr Phase:$::phase
set ::listener [H listen process [list ::apply {{r} {
#set delay [expr {int(10000 * rand())}]
#after $delay
set val [string trim [dict get $r -Header uri] /]
#puts stderr "DO: $val"
Ok $r $val text/html
}}] $::port]
set cmd [list ::apply {{count token} {
if {[catch {
upvar #0 $token r
if {$r(status) ne "ok"} {
puts stderr FAIL-$count:[array get r]
} else {
#puts stderr GOT:$r(body)-[array size ::result]
if {$r(body) != $count} {
error "Body and Count out of sync"
}
unset ::result($r(body))
if {[array size ::result] == 0} {
chan close $::listener
incr ::phase ;# completed phase
puts stderr "Multi-GET complete"
}
}
} e eo]} {
puts stderr ERR:'$e'($eo)/([array get r])
}
}}]
for {set i 0} {$i < $::maxports} {incr i} {
set ::result($i) [::http::geturl http://localhost:$::port/$i -timeout 10000 -command [list {*}$cmd $i]]
}
}}}
vwait phase ;# wait for this testing phase to finish
# the tests need to be in event space
after 0 {::apply {{} {
puts stderr Phase:$::phase
set listener [H listen process [list ::apply {{r} {
puts stderr "SETTING[info coroutine] ($r)"
after [expr {int(10000 * rand())}] [info coroutine]
::yieldto return -level 0 -code break
set socket [dict get $r -socket]
set val [string trim [dict get $r -Header uri] /]
set result [Ok $r $val text/html]
puts stderr "TRIGGER[info coroutine]: $val - $socket -> $result"
::H::tx_$socket $result
}}] $::port]
variable port
for {set i 0} {$i < $::maxports} {incr i} {
set cmd [list ::apply {{count token} {
if {[catch {
upvar #0 $token r
if {$r(status) ne "ok"} {
puts stderr FAIL-$count:[array get r]
} else {
puts stderr GOT:$r(body)/[array size ::result]
if {$r(body) != $count} {
error "Body $r(body) and Count $count out of sync"
}
unset ::result($r(body))
if {[array size ::result] == 0} {
incr ::phase
chan close $::listener
}
}
} e eo]} {
puts stderr ERR:'$e'($eo)/([array get r])
}
}} $i]
set ::result($i) [::http::geturl http://localhost:$::port/$i -timeout 100000 -command $cmd]
}
}}}
vwait phase
}