blob: 5385a9cc36e52cea52676c191d579ed1de31ac64 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
#!/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
}
}
|
