From d27d0fd403474b132f8a2ee25857d267f8f0f12a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Anton=20Luka=20=C5=A0ijanec?= <anton@sijanec.eu>
Date: Sun, 7 Aug 2022 22:40:59 +0200
Subject: somewhat working http server

---
 www.tcl | 121 +++++++++++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 85 insertions(+), 36 deletions(-)

diff --git a/www.tcl b/www.tcl
index e057844..2dcf976 100755
--- a/www.tcl
+++ b/www.tcl
@@ -5,109 +5,142 @@ namespace eval www {
 
 	oo::class create server {
 		constructor {{ports 0} {acts {}}} {
-			my variable sock actions
+			my variable actions
 			set actions $acts
 			foreach port $ports {
 				my bind $port
 			}
 		}
+		destructor {
+			my variable sockets
+			foreach sock $sockets {
+				close $sock
+			}
+		}
+		method ports {} {
+			my variable sockets
+			foreach sock $sockets {
+				lappend ports [lindex [chan configure $sock -sockname] 2]
+			}
+			return $ports
+		}
 		# actions of existing clients (where request is ongoing) aren't modified, only actions for new clients
 		method action {uri handler} {
 			my variable actions
 			dict set actions $uri $handler
 		}
 		method bind {{port 0}} {
-			socket -server "[self namespace] accept" $port
+			my variable sockets
+			lappend sockets [socket -server "[self] accept" $port]
 		}
 		method accept {chan addr port} {
 			my variable actions
 			if [dict exists	$actions accept] {
 				[{*}[dict get $actions accept] $chan $addr $port]
 			}
-			client new $chan $actions
+			::www::client new $chan $actions
 		}
 	}
 
 	oo::class create client {
-		constructor {sock {actions {}}} {
-			my variable sock stage actions
+		constructor {sock {acts {}}} {
+			my variable chan stage actions
 			set stage headers
 			set chan $sock
-			chan event $chan readable {[self namespace] readable}
+			set actions $acts
+			chan event $chan readable "[self] readable"
 			chan configure $chan -blocking 0
 		}
-		destructor {} {
-			my variable sock
-			close sock
+		destructor {
+			my variable chan
+			close $chan
 		}
-		method readable {
-			my variable to_parse chan stage headers arguments uri
+		method readable {} {
+			my variable to_parse chan stage headers arguments uri path body
 			switch $stage {
 				headers {
-					if {[catch {append to_parse {gets $chan}}] != 0} {
+					if {[catch {append to_parse [read $chan]}] != 0} {
 						my destroy
 					}
 					if {[string first "\n\n" $to_parse] != -1} {
-						set list [split $to_parse ":\n"]
-						
-						set uri [lindex [split [lindex $list 0] " "] 1]
-						set headers [lreplace $list 0 0]
-						
+						set raw_headers [split $to_parse "\n"]
 						set i 0
-						dict map {key value} $headers {
-							if {expr {[incr i] % 2}} {
-								set key [string tolower $key]
+						foreach hdr [lreplace $raw_headers 0 0] {
+							lappend headers [string trim [lindex [split $hdr :] 0]]
+							set value [lreplace [split $hdr :] 0 0]
+							lappend headers [string trim [join $value :]]
+						}
+						
+						set components {}
+						foreach component [split [lindex $raw_headers 0] " "] {
+							if {$component != {}} {
+								lappend components $component
 							}
 						}
+						set uri [lindex $components 1]
 						
-						set variables [split [lindex [split $uri "?"] 1] "&=;"]
+						dict map {key value} $headers {
+							set key [string tolower $key]
+						}
+
+						set path [lindex [split $uri "?"] 0]
+						set arguments [split [lindex [split $uri "?"] 1] "&=;"]
 
 						set body {}
-						if [dict exists content-length] {
+						if [dict exists $headers content-length] {
 							set stage body
 							set to_parse {}
 							chan configure $chan -translation {binary auto} -encoding binary -eofchar {{} {}}
 						} else {
+							set stage read
 							my request_complete
 						}
 					}
 				}
 				body {
-					if {[catch {append to_parse {gets $chan}}] != 0} {
+					if {[catch {append to_parse [read $chan]}] != 0} {
 						my destroy
 					}
 					if {[string length to_parse] == [dict get $headers content-length]} {
+						lappend arguments {*}[split $to_parse "%=;"]
+						set body $to_parse
+						set stage read
 						my request_complete
 					}
 				}
+				read {
+
+				}
 			}
 		}
-		method request_complete {
-			my variable actions headers arguments uri body
+		method request_complete {} {
+			my variable actions headers arguments uri body path
 			dict for {key value} $actions {
 				if [string match -nocase $key $uri] {
-					return [{*}$value $arguments $headers $body]
+					return [{*}$value [self] $path $arguments $headers $body $uri]
 				}
 			}
-			return [my send {content-type text/plain} {404 not found-ni najdeno} {404 not found-ni najdeno}]
+			return [my send {404 not found-ni najdeno} {content-type text/plain} {404 not found-ni najdeno
+}]
 		}
-		# uri is "string match". handler gets parsed array of request variables, request headers and request body
-		method send {headers body code} {
+		method send {code headers body} {
 			my variable to_write chan data
 			# cr is auto translated to crlf for network sockets in tcl
 			set to_write "HTTP/1.0 $code
-			Connection: close
-			"
+Connection: close
+"
 			dict for {key value} $headers {
 				append to_write "$key: $value
-				"
+"
 			}
+			append to_write "
+"
 			set data $body
-			chan event $chan writable {[self namespace] writable}
+			chan event $chan writable "[self] writable"
 		}
 		method writable {} {
-			my variable chan to_write
-			if {[catch {[puts -nonewline $chan $to_write}] != 0} {
+			my variable chan to_write data
+			if {[catch {puts -nonewline $chan $to_write}] != 0} {
 				my destroy
 			}
 			chan configure $chan -translation {binary binary} -encoding binary
@@ -116,6 +149,22 @@ namespace eval www {
 			my destroy
 		}
 	}
-	if {$argv0 == www.tcl} {
+	if [string match *www.tcl* $argv0] {
+		proc action {client path arguments headers body uri} {
+			$client send {200 ok} {content-type text/html} "
+				<h1>hello world from <code>www.tcl</code><h1>
+				<p>request path: <pre>$path</pre></p>
+				<p>request uri: <pre>$uri</pre></p>
+				<p>request arguments: <pre>$arguments</pre></p>
+				<p>request headers: <pre>$headers</pre></p>
+				<p>request body: <pre>$body</pre></p>
+				<form method=post>
+				<input name=input placeholder='try sending something'><input type=submit>
+				</form>
+"
+		}
+		server create s 8251 "/* [namespace which action]"
+		puts "http://127.0.0.1:[s ports]/helloworld"
+		vwait forever
 	}
 }
-- 
cgit v1.2.3