Posted to tcl by Napier at Tue May 26 09:21:50 GMT 2015view raw

  1. ## Other required packages.
  2.  
  3. lappend auto_path /remote/Store/Prg/tclpkg
  4. package require uri
  5. package require base64
  6. package require tls
  7.  
  8.  
  9. ## Tuning parameters.
  10. set tuning {
  11. header_lines_max 30
  12. request_timeout 5000
  13. zip_minimum 0
  14. zip_level 9
  15. }
  16.  
  17.  
  18.  
  19. ## Put anything httpd into an own namespace.
  20. namespace eval ::httpd {
  21. ## Accept incoming connection.
  22. variable Directory /remote/Store/Common/Dash/atv/
  23.  
  24. proc accept {sock ip port} {
  25. puts "Accept from $ip $port"
  26. ## Start coroutine for client.
  27. chan event $sock readable [coroutine ::httpd::reader$sock apply {{sock ip port} {
  28. ## Return the coroutine command on first call so "chan event" can remember it.
  29. yield [info coroutine]
  30.  
  31. ## This any the parts after subsequent "yields" are called automatically by the "chan event" mechanism.
  32. try {
  33. ## Start a timeout for the requests.
  34. set timeout [after [dict get $::tuning request_timeout] [list ::httpd::timeout $sock [info coroutine]]]
  35.  
  36. ## Do nonblocking I/O on client socket.
  37. chan configure $sock -blocking 0
  38.  
  39. ## Read requests subsequently.
  40. while {1} {
  41. ## HTTP headers are ascii encoded with CRLF line ends, line buffering is fine.
  42. chan configure $sock -encoding ascii -translation crlf -buffering line
  43.  
  44. ## Read the request line.
  45. set request {}
  46. while {$request eq {}} {
  47. ## Get request.
  48. chan gets $sock request
  49.  
  50. ## Return control to the event loop in the blocked case.
  51. if {[chan blocked $sock]} yield
  52.  
  53. ## End coroutine when client has closed the channel.
  54. if {[chan eof $sock]} return
  55. }
  56.  
  57. ## Default header values.
  58. set headers {}
  59. dict set headers Accept-Encoding "identity;q=0.001"
  60.  
  61. ## Read additional header lines.
  62. for {set i 0} {$i < [dict get $::tuning header_lines_max]} {incr i} {
  63. ## Read header line.
  64. chan gets $sock headerline
  65.  
  66. ## Return control to the event loop in the blocked case.
  67. if {[chan blocked $sock]} yield
  68.  
  69. ## It's an error to have an eof before header end (empty line).
  70. if {[chan eof $sock]} { throw {HTTPD REQUEST_HEADER CONNECTION_CLOSED} "connection closed by client during read of HTTP request header"}
  71.  
  72. ## Break loop on last header line.
  73. if {$headerline eq {}} break
  74.  
  75. ## This is a regular header line.
  76. ## Remember field name and value. Repeated field values are lappended.
  77. set sep [string first ":" $headerline]
  78. dict lappend headers [string range $headerline 0 $sep-1] [string trim [string range $headerline $sep+1 end]]
  79. }
  80.  
  81. ## Complain about too many header lines.
  82. if {$i == [dict get $::tuning header_lines_max]} { throw {HTTPD REQUEST_HEADER TOO_MANY_LINES} "too many header lines in HTTP request" }
  83.  
  84. ## Join appended header fields with comma,space (RFC2616, section 4.2).
  85. dict for {name values} $headers {
  86. dict set headers $name [join $values ", "]
  87. }
  88.  
  89. ## Get HTTP method, protocol version and URL.
  90. lassign $request method url version
  91.  
  92. ## Parse "Accept-Encoding" header. Defaults to "identity" if none is present.
  93. set accepted_encodings [parseHeaderList [dict get $headers Accept-Encoding]]
  94.  
  95. ## Respond by method.
  96. switch -- $method {
  97. HEAD - GET {
  98. ## Handle the single request.
  99. set data [handleRequest $method $url $version $headers {}]
  100.  
  101. ## Sort out clients which don't accept zipped content at all.
  102. if {$accepted_encodings ne "identity"} {
  103. ## Check if content is worth it (long enough, not already zipped internally).
  104. if {[string length [dict get $data content]] >= [dict get $::tuning zip_minimum]} {
  105. switch -glob -- [dict get $data content-type] {
  106. "text/*" {
  107. ## Go through list of accepted encodings.
  108. foreach enc $accepted_encodings {
  109. switch -- $enc {
  110. deflate - x-deflate {
  111. ## Zip content as raw LZW stream.
  112. dict set data content [zlib deflate [dict get $data content] [dict get $::tuning zip_level]]
  113.  
  114. ## Add header field.
  115. dict set data headers Content-Encoding $enc
  116.  
  117. ## Do not apply another encoding.
  118. break
  119. }
  120. gzip - x-gzip {
  121. ## Zip content as GZIP stream (see RFC 1952).
  122. dict set data content [zlib gzip [dict get $data content] -level [dict get $::tuning zip_level]]
  123.  
  124. ## Add header field.
  125. dict set data headers Content-Encoding $enc
  126.  
  127. ## Do not apply another encoding.
  128. break
  129. }
  130. compress {
  131. ## Zip content as ZLIB compressed stream.
  132. dict set data content [zlib compress [dict get $data content] [dict get $::tuning zip_level]]
  133.  
  134. ## Add header field.
  135. dict set data headers Content-Encoding $enc
  136.  
  137. ## Do not apply another encoding.
  138. break
  139. }
  140. }
  141. }
  142. }
  143. "image/*" {
  144. dict set data headers Accept-Ranges bytes
  145. }
  146. }
  147. }
  148. }
  149.  
  150. ## Send result header.
  151. chan configure $sock -encoding ascii -translation crlf -buffering full
  152. puts $sock "$version [dict get $data code] OK"
  153. puts $sock "Content-Type: [dict get $data content-type]"
  154. puts $sock "Content-Length: [string length [dict get $data content]]"
  155. foreach {field value} [dict get $data headers] {
  156. puts $sock "$field: $value"
  157. }
  158. puts $sock ""
  159. }
  160. default {
  161. throw {HTTPD REQUEST_METHOD UNSUPPORTED} "unsupported HTTP method in request"
  162. }
  163. }
  164. switch -- $method {
  165. GET {
  166. ## Send result.
  167. chan configure $sock -translation binary
  168. puts -nonewline $sock [dict get $data content]
  169. }
  170. }
  171.  
  172. ## Flush output before reading next request.
  173. chan flush $sock
  174. }
  175. } trap {HTTPD REQUEST_HEADER TOO_MANY_LINES} {} {
  176. puts stderr "HTTPD REQUEST_HEADER TOO_MANY_LINES $ip"
  177. } trap {HTTPD REQUEST_HEADER CONNECTION_CLOSED} {} {
  178. puts stderr "HTTPD REQUEST_HEADER CONNECTION_CLOSED $ip"
  179. } trap {HTTPD REQUEST_METHOD UNSUPPORTED} {} {
  180. puts stderr "HTTPD REQUEST_METHOD UNSUPPORTED $ip"
  181. } trap {POSIX ECONNABORTED} {} {
  182. puts stderr "SSL ERROR $ip"
  183. } on error {} {
  184. puts stderr "$::errorCode $::errorInfo"
  185. } finally {
  186. close $sock
  187. after cancel $timeout
  188. }
  189. } ::httpd} $sock $ip $port]
  190. }
  191.  
  192.  
  193. ## Handle timeout.
  194. proc timeout {sock coroutine_id} {
  195. ## Close the channel.
  196. close $sock
  197.  
  198. ## Remove the coroutine
  199. rename $coroutine_id {}
  200. }
  201.  
  202.  
  203. ## Parse lists in HTTP header fields.
  204. proc parseHeaderList {list} {
  205. ## Go through all list items.
  206. foreach item [split $list ","] {
  207. ## First subfield is a name.
  208. set type [string trimleft [lindex [split $item ";"] 0]]
  209.  
  210. ## Parse other subfields. RF2616 demands quality "q=..." is the second field, but we are more generous.
  211. set q 1.0
  212. set ext {}
  213. foreach subfield [lrange [split $item ";"] 1 end] {
  214. lassign [split $subfield "="] subfield_name subfield_value
  215. switch -- [string trimleft $subfield_name] {
  216. q {set q $subfield_value}
  217. default {append ext $subfield}
  218. }
  219. }
  220.  
  221. ## Remember item name by quality.
  222. ## Any extension is appended to the type.
  223. dict lappend ql $q [concat $type $ext]
  224. }
  225.  
  226. ## Return list items sorted by q value. Remove "q=0" row
  227. dict unset ql 0
  228. set result {}
  229. foreach {q types} [lsort -stride 2 -real -decreasing $ql] {
  230. lappend result {*}$types
  231. }
  232. return $result
  233. }
  234.  
  235.  
  236. ## Handle a single HTTP request.
  237. proc handleRequest {method url version headers indata} {
  238. puts "Handle Request"
  239. puts "$method"
  240. puts "$url"
  241. puts "$version"
  242. puts "$headers"
  243. puts "$indata"
  244. if {$url == "/artwork.png"} {set data [serveImage -name artwork.png]} else {set data ""}
  245. dict set result code "200"
  246. # charset=[encoding system]
  247. dict set result content $data
  248. dict set result content-type "image/png"
  249. dict set result headers {}
  250. return $result
  251. }
  252.  
  253. proc serveImage {args} {
  254. #### ::Tools::readFile
  255. ### Reads the specified file and returns its contents
  256. ## Arguments:
  257. # -name : The name of the file to read in the modules Common Directory.
  258. variable Directory
  259. if {[dict exists $args -name]} {set name [dict get $args -name]} else {UCL 5 "ERROR: No Name provided to ::Tools::createFile"; return}
  260. if {[info exists Directory]} {} else {UCL 5 "ERROR: Variable ::DashOS::Directory Doesn't Exist"; return}
  261. set filePath "${Directory}/${name}"
  262. if {![file isfile $filePath]} {return -1}
  263. set f [open $filePath rb]
  264. set contents [read -nonewline $f]
  265. close $f
  266. return $contents
  267. }
  268. }
  269.  
  270.  
  271. ## Prepare the server.
  272. #::tls::init \
  273. -certfile server-public.pem \
  274. -keyfile server-private.pem \
  275. -ssl2 1 -ssl3 1 -tls1 0 \
  276. -require 0 -request 0
  277. #::tls::socket -server ::httpd::accept 9005
  278. socket -server ::httpd::accept 9005
  279.  
  280.  
  281.  
  282. ## Start Tcl event loop.
  283. vwait forever