summaryrefslogtreecommitdiffstats
path: root/www.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'www.tcl')
-rwxr-xr-xwww.tcl121
1 files changed, 121 insertions, 0 deletions
diff --git a/www.tcl b/www.tcl
new file mode 100755
index 0000000..e057844
--- /dev/null
+++ b/www.tcl
@@ -0,0 +1,121 @@
+#!/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} {
+ }
+}