path: root/www.tcl

#!/usr/bin/tclsh
namespace eval www {

	package require TclOO

	oo::class create server {
		constructor {{ports 0} {acts {}}} {
			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}} {
			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
			}
			::www::client new $chan $actions
		}
	}

	oo::class create client {
		constructor {sock {acts {}}} {
			my variable chan stage actions
			set stage headers
			set chan $sock
			set actions $acts
			chan event $chan readable "[self] readable"
			chan configure $chan -blocking 0
		}
		destructor {
			my variable chan
			close $chan
		}
		method readable {} {
			my variable to_parse chan stage headers arguments uri path body
			switch $stage {
				headers {
					if {[catch {append to_parse [gets $chan]}] != 0} {
						my destroy
					}
					append to_parse "\n"
					if {[string first "\n\n" $to_parse] != -1} {
						set raw_headers [split $to_parse "\n"]
						set i 0
						foreach hdr [lreplace $raw_headers 0 0] {
							lappend hdrs [string trim [lindex [split $hdr :] 0]]
							set value [lreplace [split $hdr :] 0 0]
							lappend hdrs [string trim [join $value :]]
						}
						
						set components {}
						foreach component [split [lindex $raw_headers 0] " "] {
							if {$component != {}} {
								lappend components $component
							}
						}
						set uri [lindex $components 1]
						
						dict for {key value} $hdrs {
							dict append headers [string tolower $key] $value
						}

						set path [lindex [split $uri "?"] 0]
						set arguments [split [lindex [split $uri "?"] 1] "&=;"]

						set body {}
						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 [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 path
			dict for {key value} $actions {
				if [string match -nocase $key $path] {
					return [{*}$value [self] $path $arguments $headers $body $uri]
				}
			}
			return [my send {404 not found-ni najdeno} {content-type text/plain} {404 not found-ni najdeno
}]
		}
		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
"
			dict for {key value} $headers {
				append to_write "$key: $value
"
			}
			append to_write "
"
			set data $body
			chan event $chan writable "[self] writable"
		}
		method writable {} {
			my variable chan to_write data
			if {[catch {puts -nonewline $chan $to_write}] != 0} {
				my destroy
			}
			chan configure $chan -translation {binary binary} -encoding binary
			if {[catch {puts -nonewline $chan $data}] != 0} {
			}
			my destroy
		}
	}
	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 0 "/* [namespace which action]"
		puts "http://127.0.0.1:[s ports]/helloworld"
		vwait forever
	}
}