diff options
Diffstat (limited to 'http.tcl')
| -rwxr-xr-x | http.tcl | 189 |
1 files changed, 189 insertions, 0 deletions
diff --git a/http.tcl b/http.tcl new file mode 100755 index 0000000..7bc799e --- /dev/null +++ b/http.tcl @@ -0,0 +1,189 @@ +# From configuration +# root Directory which files reside in. + +namespace eval http { + + # server channel address port + # Server process + # + # content-type filename + # Find the MIME content type of a file + # + # send-file channel filename + # Open and send a file. + # + # respond channel status ?optional + # Makes HTTP response with status on channel. Optional is an optional argument with various meanings. + # + # error-page status + # Returns a small error page. + + variable status_codes \ + [dict create \ + 200 {OK} \ + 301 {Moved Permanently} \ + 400 {Bad Request} \ + 404 {Not Found} \ + ] + + variable mime_types \ + [dict create \ + .txt text/plain \ + .html text/html \ + .css text/css \ + {} text/html \ + .png image/png \ + .jpg image/jpeg \ + .ttf font/ttf \ + .pdf application/pdf \ + .mp3 audio/mpeg \ + ] + + proc server {channel address port} { + variable hook_namespace; + variable root; + + ## (1) Handle first line + puts "(1)" + + gets $channel line + set request_target [request_target::get $channel $line] + + ## (2) Get rest of packet. + set packet {} + while { [gets $channel line] } { + puts $line + puts -nonewline "field-line...";#!!!!!!!!!!!!! + flush stdout + ## Check if field-line is in correct form. + ## ^field-name : OWS field-value OWS $ + if [expr ![regexp {^[[:alpha:]-]+(:){1}[[:space:]]?[[:print:]]+[[:space:]]?$} $line]] { + respond $channel 400 + } + puts " fine!";#!!!!!!!!!!!!! + + + puts -nonewline "Host duplicates...";#!!!!!!!!!!!!! + + ## Reject duplicates of the host field. + set key [string tolower [string range $line 0 [expr [string first : $line] - 1]]] + puts -nonewline "key is $key ... [string compare $key host] and [lsearch $packet host] ...";#!!!! + flush stdout + if [expr ([string compare $key "host"] == 0) && ([lsearch $packet "host"] != -1)] { + respond $channel 400 + } + puts " fine!";#!!!!!!!!!!!!! + ## Add to packet dictionary + dict append packet \ + [string tolower [string range $line 0 [expr [string first : $line] - 1]]] \ + [string range $line [expr [string first : $line] + 2] end] + } + + ## Reject packets that have no host field. + if {[lsearch [dict keys $packet] "host"] == -1} { + respond $channel 400 + } + + + ## (3) If all is good, then respond. + puts "All good!" + # If file exists, then 200 OK! + set filename [string cat $root [request_target::file $request_target]] + puts "Getting file $filename" + if [file exists $filename] { + respond $channel 200 $filename + } + + #TODO: Make some filler for this. + # If it's one of the targets of the imported namespace, then 200 OK! + #if [namespace eval $hook_namespace [string cat {lsearch $targets } "$filename"]] { + # respond $channel 200 $filename + #} + + puts "Actually, 404" + # Then I guess it doesn't exist. + respond $channel 404 + } + + proc content-type {filename} { + variable mime_types; + return [dict get $mime_types [file extension $filename]] + } + + # Sends an opened file or cached file. + proc send-file {channel filename} { + #TODO: configure it to try the cache. + #TODO: configure channels to use binary translation if content type is not text/* + set file [open $filename] + fcopy $file $channel + close $file + } + + ## Header + ## optional stands for a few different values. + ## 200 : Request Target + ## 3xx : Location + proc respond {channel status {optional {}}} { + + ## Import Variables + variable root; + variable status_codes; + variable hook_namespace; + ## New Variables + variable content {}; + variable response {}; + + ## If it's not a status code we know, then error, it's your fault! + if [expr [lsearch [dict keys $status_codes] $status] == -1] { + error "Invalid status response" + } + + ## (1) Give Status Line + append response "HTTP/1.1 $status [dict get $status_codes $status]\n" + append response "Server: unknown\n" + #append response "Last-Modified: Sun, 14 Apr 2024 01:58:24 GMT\n" + append response "Date: [clock format [clock seconds] -format {%a, %d %b %Y %T GMT} -gmt 1]\n" + + if { $status == 200 } { + if [file exists $optional] { + append response "Content-Length: [file size $optional]\n" + append response "Content-Type: [content-type $optional]\n" + append response "\n" + puts -nonewline $channel $response + send-file $channel $optional + } else { + #TODO: implement this when have something to implement! + set content "Sup mate!" + append response "Content-Length: [string bytelength $content]\n" + append response "Content-Type: text/html\n" + append response "\n" + puts -nonewline $channel $response + puts -nonewline $channel $content + } + # give a Last-Modified: field + puts -nonewline $channel $response + } else { + ## Error Page + set content [error-page $status] + append response "Content-Type: text/html\n" + append response "Content-Length: [string bytelength $content]\n" + if [expr ($status >= 300) && ($status <= 308) && ([string compare $optional {}] != 0)] { + append response "Location: $optional\n" + } + append response "\n" + puts -nonewline $channel $response + puts -nonewline $channel $content + } + close $channel + return -level 2 + } + + + proc error-page {status {location {}}} { + variable status_codes + return "<html><head><title>Status: $status</title></head><body style='font-size:48px;text-align:center'><b style='font-size:72px'>$status</b><br>[dict get $status_codes $status]</body></html>" + } + + + source http-request_target.tcl +} |