summaryrefslogtreecommitdiffstats
path: root/www.tcl
blob: e5cd36f1d088e7381a0bd9dfdbd19a34664ea8b8 (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 $uri] {
					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
	}
}