diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rwxr-xr-x | README | 6 | ||||
| -rwxr-xr-x | configure.tcl | 19 | ||||
| -rwxr-xr-x | http-request_target.tcl | 115 | ||||
| -rwxr-xr-x | http.tcl | 189 | ||||
| -rwxr-xr-x | main.tcl | 8 |
6 files changed, 338 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ @@ -0,0 +1,6 @@ +This server serves a subset of HTTP. +It has currently only implemented what is necessary to serve GET requests, because I do not want much more than this. + +Configuration is performed with the configure.tcl file, the others should not need to be touched. +- for now, perhaps later we can do a simple config file +- You can configure it to hook into Tcl diff --git a/configure.tcl b/configure.tcl new file mode 100755 index 0000000..717a59d --- /dev/null +++ b/configure.tcl @@ -0,0 +1,19 @@ +## Set your variables here. + +namespace eval http { + # The directory which files are searched for. + variable root {/home/aleksei/www/files/} + # hook_namespace refers to a user-created namespace. + # It must have some things such as + # A proc 'main' which is what the server will execute to get information. + # A list $targets which have all the valid targets. + variable hook_namespace {} +} + + +## Import HTML Generating Modules + + +## Validate configuration variables. +## Especially file exists content +## Especially validate the existence of necessary components in $content diff --git a/http-request_target.tcl b/http-request_target.tcl new file mode 100755 index 0000000..ca567f9 --- /dev/null +++ b/http-request_target.tcl @@ -0,0 +1,115 @@ +namespace eval request_target { + + # get channel first_line + # Get request_target from the first line + # + # file request_target + # File portion of request_target + # + # query request_target + # Decoded query portion of request_target + # + # encode query + # Encode a query + # + # decode query + # Decode a query + + ## Gets the request_target from the first client line. + proc get {channel first_line} { + + ## Reject if first line is not a properly formatted GET request. + ## ^GET RWS - HTTP/(Versions) $ + if { ![regexp {^(GET ){1}.* HTTP/(0.9|1.0|1.1){1}$} $first_line] } { + ::http::respond $channel 400 + } + ## Return between first and last space. + set request_target [string trim \ + [string range $first_line \ + [string first " " $first_line] \ + [string last " " $first_line]]] + puts "|$request_target|" + + ## If there are two periods in a request target (trying to access parent files), reject. + if [regexp {\.\./} $request_target] { + respond 400 + } + + if [regexp {^/.*$} $request_target] { + puts "origin-form" + return $request_target + } + + ## Turn absolute-form to origin-form + if [regexp {^http(s)?://[[:alpha:].]+/[[:graph:]*]} $request_target] { + set request_target \ + [string range $request_target \ + [expr [string first / [string range $request_target 8 end]] + 8] \ + end] + return $request_target + } + + puts "Neither origin-form or absolute-form" + respond 400; + } + + + #TODO: Will need to improve these functions later. + + ## Take the file part of the request target. + proc file {request_target} { + set t [string first ? $request_target] + if {$t == -1} { + return [string range $request_target 1 end] + } + else { + return [string range $request_target 1 [expr $t - 1]] + } + } + + ## Process request_target into a query string. + proc query {request_target} { + set t [string first ? $request_target] + if {$t == -1} { + return {} + } + else { + return [decode [string map {& { } = { }} \ + [string range $request_target \ + [expr $t + 1] end]]] + } + } + + ## Create dictionaries for coding and decoding query strings. + variable character2code {}; + variable code2character {}; + for {set i 0} {$i <= 255} {incr i 1} { + set ch [format %c $i]; + if {[expr !( [string is alpha $ch] || [string is digit $ch] )]} { + set co "\%[format %02X $i]"; + dict append character2code $ch $co + dict append code2character $co $ch + } + } + + proc encode {query} { + variable character2code + for {set i 0} {$i < [llength $query]} {incr i 1} { + lset query $i \ + [string map -nocase $character2code [lindex $query $i]] + } + set query [string map -nocase {{ } {%20}} $query] + return $query + } + + proc decode {query} { + variable code2character + for {set i 0} {$i < [llength $query]} {incr i 1} { + lset query $i \ + [string map -nocase $code2character [lindex $query $i]] + } + set query [string map -nocase {{%20} { }} $query] + return $query + } + +} 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 +} diff --git a/main.tcl b/main.tcl new file mode 100755 index 0000000..bd24e69 --- /dev/null +++ b/main.tcl @@ -0,0 +1,8 @@ +#!/bin/tclsh + +source configure.tcl +source http.tcl + +socket -server http::server 8000 + +vwait forever |