Posted to tcl by Napier at Tue May 26 09:21:50 GMT 2015view raw
- ## 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