summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rwxr-xr-xwww.tcl121
1 files 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
}
}