path: root/www.tcl

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

	package require TclOO

	oo::class create server {
		constructor {{ports 0} {acts {}}} {
			my variable sock actions
			set actions $acts
			foreach port $ports {
				my bind $port
			}
		}
		# 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
		}
		method accept {chan addr port} {
			my variable actions
			if [dict exists	$actions accept] {
				[{*}[dict get $actions accept] $chan $addr $port]
			}
			client new $chan $actions
		}
	}

	oo::class create client {
		constructor {sock {actions {}}} {
			my variable sock stage actions
			set stage headers
			set chan $sock
			chan event $chan readable {[self namespace] readable}
			chan configure $chan -blocking 0
		}
		destructor {} {
			my variable sock
			close sock
		}
		method readable {
			my variable to_parse chan stage headers arguments uri
			switch $stage {
				headers {
					if {[catch {append to_parse {gets $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 i 0
						dict map {key value} $headers {
							if {expr {[incr i] % 2}} {
								set key [string tolower $key]
							}
						}
						
						set variables [split [lindex [split $uri "?"] 1] "&=;"]

						set body {}
						if [dict exists content-length] {
							set stage body
							set to_parse {}
							chan configure $chan -translation {binary auto} -encoding binary -eofchar {{} {}}
						} else {
							my request_complete
						}
					}
				}
				body {
					if {[catch {append to_parse {gets $chan}}] != 0} {
						my destroy
					}
					if {[string length to_parse] == [dict get $headers content-length]} {
						my request_complete
					}
				}
			}
		}
		method request_complete {
			my variable actions headers arguments uri body
			dict for {key value} $actions {
				if [string match -nocase $key $uri] {
					return [{*}$value $arguments $headers $body]
				}
			}
			return [my send {content-type text/plain} {404 not found-ni najdeno} {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} {
			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
				"
			}
			set data $body
			chan event $chan writable {[self namespace] writable}
		}
		method writable {} {
			my variable chan to_write
			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 {$argv0 == www.tcl} {
	}
}