Initial; already done much

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 @@
+*~
diff --git a/README b/README
new file mode 100755
index 0000000..b56a36b
--- /dev/null
+++ b/README
@@ -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