Posted to tcl by Napier at Tue May 26 09:21:50 GMT 2015view pretty
## Other required packages.
lappend auto_path /remote/Store/Prg/tclpkg
package require uri
package require base64
package require tls
## Tuning parameters.
set tuning {
header_lines_max 30
request_timeout 5000
zip_minimum 0
zip_level 9
}
## Put anything httpd into an own namespace.
namespace eval ::httpd {
## Accept incoming connection.
variable Directory /remote/Store/Common/Dash/atv/
proc accept {sock ip port} {
puts "Accept from $ip $port"
## Start coroutine for client.
chan event $sock readable [coroutine ::httpd::reader$sock apply {{sock ip port} {
## Return the coroutine command on first call so "chan event" can remember it.
yield [info coroutine]
## This any the parts after subsequent "yields" are called automatically by the "chan event" mechanism.
try {
## Start a timeout for the requests.
set timeout [after [dict get $::tuning request_timeout] [list ::httpd::timeout $sock [info coroutine]]]
## Do nonblocking I/O on client socket.
chan configure $sock -blocking 0
## Read requests subsequently.
while {1} {
## HTTP headers are ascii encoded with CRLF line ends, line buffering is fine.
chan configure $sock -encoding ascii -translation crlf -buffering line
## Read the request line.
set request {}
while {$request eq {}} {
## Get request.
chan gets $sock request
## Return control to the event loop in the blocked case.
if {[chan blocked $sock]} yield
## End coroutine when client has closed the channel.
if {[chan eof $sock]} return
}
## Default header values.
set headers {}
dict set headers Accept-Encoding "identity;q=0.001"
## Read additional header lines.
for {set i 0} {$i < [dict get $::tuning header_lines_max]} {incr i} {
## Read header line.
chan gets $sock headerline
## Return control to the event loop in the blocked case.
if {[chan blocked $sock]} yield
## It's an error to have an eof before header end (empty line).
if {[chan eof $sock]} { throw {HTTPD REQUEST_HEADER CONNECTION_CLOSED} "connection closed by client during read of HTTP request header"}
## Break loop on last header line.
if {$headerline eq {}} break
## This is a regular header line.
## Remember field name and value. Repeated field values are lappended.
set sep [string first ":" $headerline]
dict lappend headers [string range $headerline 0 $sep-1] [string trim [string range $headerline $sep+1 end]]
}
## Complain about too many header lines.
if {$i == [dict get $::tuning header_lines_max]} { throw {HTTPD REQUEST_HEADER TOO_MANY_LINES} "too many header lines in HTTP request" }
## Join appended header fields with comma,space (RFC2616, section 4.2).
dict for {name values} $headers {
dict set headers $name [join $values ", "]
}
## Get HTTP method, protocol version and URL.
lassign $request method url version
## Parse "Accept-Encoding" header. Defaults to "identity" if none is present.
set accepted_encodings [parseHeaderList [dict get $headers Accept-Encoding]]
## Respond by method.
switch -- $method {
HEAD - GET {
## Handle the single request.
set data [handleRequest $method $url $version $headers {}]
## Sort out clients which don't accept zipped content at all.
if {$accepted_encodings ne "identity"} {
## Check if content is worth it (long enough, not already zipped internally).
if {[string length [dict get $data content]] >= [dict get $::tuning zip_minimum]} {
switch -glob -- [dict get $data content-type] {
"text/*" {
## Go through list of accepted encodings.
foreach enc $accepted_encodings {
switch -- $enc {
deflate - x-deflate {
## Zip content as raw LZW stream.
dict set data content [zlib deflate [dict get $data content] [dict get $::tuning zip_level]]
## Add header field.
dict set data headers Content-Encoding $enc
## Do not apply another encoding.
break
}
gzip - x-gzip {
## Zip content as GZIP stream (see RFC 1952).
dict set data content [zlib gzip [dict get $data content] -level [dict get $::tuning zip_level]]
## Add header field.
dict set data headers Content-Encoding $enc
## Do not apply another encoding.
break
}
compress {
## Zip content as ZLIB compressed stream.
dict set data content [zlib compress [dict get $data content] [dict get $::tuning zip_level]]
## Add header field.
dict set data headers Content-Encoding $enc
## Do not apply another encoding.
break
}
}
}
}
"image/*" {
dict set data headers Accept-Ranges bytes
}
}
}
}
## Send result header.
chan configure $sock -encoding ascii -translation crlf -buffering full
puts $sock "$version [dict get $data code] OK"
puts $sock "Content-Type: [dict get $data content-type]"
puts $sock "Content-Length: [string length [dict get $data content]]"
foreach {field value} [dict get $data headers] {
puts $sock "$field: $value"
}
puts $sock ""
}
default {
throw {HTTPD REQUEST_METHOD UNSUPPORTED} "unsupported HTTP method in request"
}
}
switch -- $method {
GET {
## Send result.
chan configure $sock -translation binary
puts -nonewline $sock [dict get $data content]
}
}
## Flush output before reading next request.
chan flush $sock
}
} trap {HTTPD REQUEST_HEADER TOO_MANY_LINES} {} {
puts stderr "HTTPD REQUEST_HEADER TOO_MANY_LINES $ip"
} trap {HTTPD REQUEST_HEADER CONNECTION_CLOSED} {} {
puts stderr "HTTPD REQUEST_HEADER CONNECTION_CLOSED $ip"
} trap {HTTPD REQUEST_METHOD UNSUPPORTED} {} {
puts stderr "HTTPD REQUEST_METHOD UNSUPPORTED $ip"
} trap {POSIX ECONNABORTED} {} {
puts stderr "SSL ERROR $ip"
} on error {} {
puts stderr "$::errorCode $::errorInfo"
} finally {
close $sock
after cancel $timeout
}
} ::httpd} $sock $ip $port]
}
## Handle timeout.
proc timeout {sock coroutine_id} {
## Close the channel.
close $sock
## Remove the coroutine
rename $coroutine_id {}
}
## Parse lists in HTTP header fields.
proc parseHeaderList {list} {
## Go through all list items.
foreach item [split $list ","] {
## First subfield is a name.
set type [string trimleft [lindex [split $item ";"] 0]]
## Parse other subfields. RF2616 demands quality "q=..." is the second field, but we are more generous.
set q 1.0
set ext {}
foreach subfield [lrange [split $item ";"] 1 end] {
lassign [split $subfield "="] subfield_name subfield_value
switch -- [string trimleft $subfield_name] {
q {set q $subfield_value}
default {append ext $subfield}
}
}
## Remember item name by quality.
## Any extension is appended to the type.
dict lappend ql $q [concat $type $ext]
}
## Return list items sorted by q value. Remove "q=0" row
dict unset ql 0
set result {}
foreach {q types} [lsort -stride 2 -real -decreasing $ql] {
lappend result {*}$types
}
return $result
}
## Handle a single HTTP request.
proc handleRequest {method url version headers indata} {
puts "Handle Request"
puts "$method"
puts "$url"
puts "$version"
puts "$headers"
puts "$indata"
if {$url == "/artwork.png"} {set data [serveImage -name artwork.png]} else {set data ""}
dict set result code "200"
# charset=[encoding system]
dict set result content $data
dict set result content-type "image/png"
dict set result headers {}
return $result
}
proc serveImage {args} {
#### ::Tools::readFile
### Reads the specified file and returns its contents
## Arguments:
# -name : The name of the file to read in the modules Common Directory.
variable Directory
if {[dict exists $args -name]} {set name [dict get $args -name]} else {UCL 5 "ERROR: No Name provided to ::Tools::createFile"; return}
if {[info exists Directory]} {} else {UCL 5 "ERROR: Variable ::DashOS::Directory Doesn't Exist"; return}
set filePath "${Directory}/${name}"
if {![file isfile $filePath]} {return -1}
set f [open $filePath rb]
set contents [read -nonewline $f]
close $f
return $contents
}
}
## Prepare the server.
#::tls::init \
-certfile server-public.pem \
-keyfile server-private.pem \
-ssl2 1 -ssl3 1 -tls1 0 \
-require 0 -request 0
#::tls::socket -server ::httpd::accept 9005
socket -server ::httpd::accept 9005
## Start Tcl event loop.
vwait forever