diff options
| -rwxr-xr-x | www.tcl | 121 |
1 files changed, 85 insertions, 36 deletions
@@ -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 } } |