Tcl Source Code

Artifact [63a30fa7fc]
Login

Artifact 63a30fa7fc4e7c9d3f28eb832a2145fbf5e716b4:

Attachment "H.tcl" to ticket [0b874c344d] added by cmcc 2013-11-23 18:42:03. (unpublished)
# 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
}