SR Technology WTK Repo
Check-in [d5b54df8b6]
Not logged in
Home Timeline Branches Tags Tickets Wiki Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added support for .css files.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: d5b54df8b6c4ec55626ca0e85a25b2f46537ecc9
User & Date: gerald 2013-01-22 02:04:19
Context
2013-01-22
18:31
Corrected mime type for CSS. check-in: bd8435682a user: gerald tags: trunk
02:04
Added support for .css files. check-in: d5b54df8b6 user: gerald tags: trunk
2013-01-20
03:15
fix mimetype for .jpg files check-in: a2a33d2625 user: stever tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to server.tcl.
︙︙
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
172

		set opcode [dict get {text 1 binary 2 ping 9} $type]
	}
	if {!$final} {
		set fragment ""
	} else {
		unset -nocomplain fragment
	}
	
	# Encode text.
	if {$type eq "text"} {
		set msg [encoding convertto utf-8 $msg]
	}
	
	# Assemble the header.
	set header [binary format c [expr {!!$final << 7 | $opcode}]]
	if {[string length $msg] < 126} {
		append header [binary format c [string length $msg]]
	} elseif {[string length $msg] < 65536} {
		append header \x7e[binary format Su [string length $msg]]
	} else {
		append header \x7f[binary format Wu [string length $msg]]
	}
	
	# Send the frame.
	chan puts -nonewline $sock $header$msg
	chan flush $sock
}

# WebSocket handler proc to receive short (up to 126 chars) text format frames
#
proc ws_receive { handler sock } {
	
	if { [chan eof $sock] } {
		close $sock
	} else {
		binary scan [read $sock 1] c opcode
		if {![info exists opcode]} {close $sock; return}
		binary scan [read $sock 1] c length
		
		set opcode [expr $opcode & 0x0F]
		set length [expr $length & 0x7F]
		
		binary scan [read $sock 4]       c* mask
		binary scan [read $sock $length] c* data
		
		set msg {}
		set i    0
		foreach char $data {
			append msg [binary format c [expr { $char^[lindex $mask [expr { $i%4 }]] }]]
			incr i
		}
		
		#$handler message $sock $msg
		#puts "ws receive $sock $msg"
		set sessionid [dict get $::sock($sock) sessionid]
		
		set cmd $msg
		if {$::events_on_stdout} {puts "WSCLIENT: $cmd"}
		[dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]
	}
}


proc ws_upgrade {sock data} {
	fileevent $sock readable {}
	
	if {[dict get $data mime,sec-websocket-version] == "13"} {
		#puts "\nVersion 13 ok"
		set acceptKey  "[dict get $data mime,sec-websocket-key]258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
		set acceptKey  [binary encode base64 [sha1::sha1 -bin $acceptKey]]
		set upgrade    "HTTP/1.1 101 Switching Protocols\r\n"
		append upgrade "Upgrade: websocket\r\n"
		append upgrade "Connection: Upgrade\r\n"
		append upgrade "WebSocket-Origin: http://[dict get $data mime,host]\r\n"
		append upgrade	"WebSocket-Location: ws://localhost:9001/wsctrl\r\n"
		append upgrade "Sec-WebSocket-Accept: $acceptKey"
		append upgrade "\r\n\r\n"
		fconfigure $sock -translation binary
		puts -nonewline $sock $upgrade
		flush $sock
		fileevent $sock readable [list ws_receive junk $sock]
		set sessionid [lindex [split [dict get $data query] =] end]
		puts "Socket $sock upgraded to WebSocket for sessionid $sessionid"
		dict set ::session($sessionid) wsock $sock
		dict set ::sock($sock) sessionid $sessionid
		
		#send initial queue of rendered objects to client
		catch {toclient $sessionid [dict get $::session($sessionid) msgq] }
		dict set ::session($sessionid) msgq ""
		
		return 1
	} else {
		#puts "\nVersion != 13 no good"
		close $sock
		return 0
	}
}

# webhandler -- Respond to HTTP requests we receive
#
# This is the callback from the webserver saying "please process this URL".
# The webserver expects us to synchronously respond to this request, returning the
# result by calling "httpd return" (or a variety of other similar calls).  If the
# request can't be responded to synchronously, we need to return an error "pending",
# and are responsible for responding to the request at a later point in time

proc webhandler {op sock} {
	
	if {$op=="handle"} {
		httpd loadrequest $sock data query
		if {![info exists data(url)]} {return}
		regsub {(^http://[^/]+)?} $data(url) {} url
		puts stderr "URL: $url"
		set url [string trimleft $url /]
		switch -glob -- $url {
			""             {httpd return $sock [filecontents index.html]}
			"*.tcl"        {httpd return $sock [newSession $sock [string trimleft $url /] lib/wtkcoreapp.html [array get data]]}
			"*.js"         {httpd return $sock [filecontents $url] -mimetype "text/javascript"}
			"*.gif"        {httpd returnfile $sock $url $url  "image/gif" [clock seconds] 1 -static }
			"*.png"        {httpd returnfile $sock $url $url  "image/png" [clock seconds] 1 -static }
			"*.jpg"        {httpd returnfile $sock $url $url  "image/jpeg" [clock seconds] 1 -static }
			"*.ico"        {httpd returnfile $sock $url $url  "image/x-icon" [clock seconds] 1 -static }
			"wtkpoll.html" {if !{[sendany $sock $query(sessionid)]} {error "pending"}}
			"wtkcb.html"   {fromclient $query(sessionid) $query(cmd)}
			"src.html"     {if {[catch {httpd return $sock [exec pygmentize -f html -O full,style=vs $query(f)]}]!=0} {httpd return $sock [filecontents $query(f)] -mimetype "text/plain"}}

			"*.html"       {httpd return $sock [filecontents $url]}
			"wsctrl"							{if {[ws_upgrade $sock [array get data]]} {error "websocket"}}
			default        {puts stderr "BAD URL $url"; httpd returnerror 404}
		}
	}
}

proc filecontents {fn} {set f [open $fn]; set d [read $f]; close $f; return $d}; # simple utility








|




|









|








|






|


|


|






|



|









|



















|



|

















|

















>
|








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
172
173

		set opcode [dict get {text 1 binary 2 ping 9} $type]
	}
	if {!$final} {
		set fragment ""
	} else {
		unset -nocomplain fragment
	}

	# Encode text.
	if {$type eq "text"} {
		set msg [encoding convertto utf-8 $msg]
	}

	# Assemble the header.
	set header [binary format c [expr {!!$final << 7 | $opcode}]]
	if {[string length $msg] < 126} {
		append header [binary format c [string length $msg]]
	} elseif {[string length $msg] < 65536} {
		append header \x7e[binary format Su [string length $msg]]
	} else {
		append header \x7f[binary format Wu [string length $msg]]
	}

	# Send the frame.
	chan puts -nonewline $sock $header$msg
	chan flush $sock
}

# WebSocket handler proc to receive short (up to 126 chars) text format frames
#
proc ws_receive { handler sock } {

	if { [chan eof $sock] } {
		close $sock
	} else {
		binary scan [read $sock 1] c opcode
		if {![info exists opcode]} {close $sock; return}
		binary scan [read $sock 1] c length

		set opcode [expr $opcode & 0x0F]
		set length [expr $length & 0x7F]

		binary scan [read $sock 4]       c* mask
		binary scan [read $sock $length] c* data

		set msg {}
		set i    0
		foreach char $data {
			append msg [binary format c [expr { $char^[lindex $mask [expr { $i%4 }]] }]]
			incr i
		}

		#$handler message $sock $msg
		#puts "ws receive $sock $msg"
		set sessionid [dict get $::sock($sock) sessionid]

		set cmd $msg
		if {$::events_on_stdout} {puts "WSCLIENT: $cmd"}
		[dict get $::session($sessionid) interp] eval wtk::fromclient [list $cmd]
	}
}


proc ws_upgrade {sock data} {
	fileevent $sock readable {}

	if {[dict get $data mime,sec-websocket-version] == "13"} {
		#puts "\nVersion 13 ok"
		set acceptKey  "[dict get $data mime,sec-websocket-key]258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
		set acceptKey  [binary encode base64 [sha1::sha1 -bin $acceptKey]]
		set upgrade    "HTTP/1.1 101 Switching Protocols\r\n"
		append upgrade "Upgrade: websocket\r\n"
		append upgrade "Connection: Upgrade\r\n"
		append upgrade "WebSocket-Origin: http://[dict get $data mime,host]\r\n"
		append upgrade	"WebSocket-Location: ws://localhost:9001/wsctrl\r\n"
		append upgrade "Sec-WebSocket-Accept: $acceptKey"
		append upgrade "\r\n\r\n"
		fconfigure $sock -translation binary
		puts -nonewline $sock $upgrade
		flush $sock
		fileevent $sock readable [list ws_receive junk $sock]
		set sessionid [lindex [split [dict get $data query] =] end]
		puts "Socket $sock upgraded to WebSocket for sessionid $sessionid"
		dict set ::session($sessionid) wsock $sock
		dict set ::sock($sock) sessionid $sessionid

		#send initial queue of rendered objects to client
		catch {toclient $sessionid [dict get $::session($sessionid) msgq] }
		dict set ::session($sessionid) msgq ""

		return 1
	} else {
		#puts "\nVersion != 13 no good"
		close $sock
		return 0
	}
}

# webhandler -- Respond to HTTP requests we receive
#
# This is the callback from the webserver saying "please process this URL".
# The webserver expects us to synchronously respond to this request, returning the
# result by calling "httpd return" (or a variety of other similar calls).  If the
# request can't be responded to synchronously, we need to return an error "pending",
# and are responsible for responding to the request at a later point in time

proc webhandler {op sock} {

	if {$op=="handle"} {
		httpd loadrequest $sock data query
		if {![info exists data(url)]} {return}
		regsub {(^http://[^/]+)?} $data(url) {} url
		puts stderr "URL: $url"
		set url [string trimleft $url /]
		switch -glob -- $url {
			""             {httpd return $sock [filecontents index.html]}
			"*.tcl"        {httpd return $sock [newSession $sock [string trimleft $url /] lib/wtkcoreapp.html [array get data]]}
			"*.js"         {httpd return $sock [filecontents $url] -mimetype "text/javascript"}
			"*.gif"        {httpd returnfile $sock $url $url  "image/gif" [clock seconds] 1 -static }
			"*.png"        {httpd returnfile $sock $url $url  "image/png" [clock seconds] 1 -static }
			"*.jpg"        {httpd returnfile $sock $url $url  "image/jpeg" [clock seconds] 1 -static }
			"*.ico"        {httpd returnfile $sock $url $url  "image/x-icon" [clock seconds] 1 -static }
			"wtkpoll.html" {if !{[sendany $sock $query(sessionid)]} {error "pending"}}
			"wtkcb.html"   {fromclient $query(sessionid) $query(cmd)}
			"src.html"     {if {[catch {httpd return $sock [exec pygmentize -f html -O full,style=vs $query(f)]}]!=0} {httpd return $sock [filecontents $query(f)] -mimetype "text/plain"}}
			"*.css"        -
                        "*.html"       {httpd return $sock [filecontents $url]}
			"wsctrl"							{if {[ws_upgrade $sock [array get data]]} {error "websocket"}}
			default        {puts stderr "BAD URL $url"; httpd returnerror 404}
		}
	}
}

proc filecontents {fn} {set f [open $fn]; set d [read $f]; close $f; return $d}; # simple utility
︙︙
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

			incr ::sessioncounter
			set isnewsess 1
		} else {
			#reuse existing session
			set sessionid $wtksess
		}
	}
	
	if {$isnewsess} {
		set interp [interp create]
		dict set ::session($sessionid) interp $interp
		dict set ::session($sessionid) sock $sock
		dict set ::session($sessionid) wsock 0
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp alias sendto toclient $sessionid
		$interp eval wtk::init sendto
	} else {
		dict set ::session($sessionid) wsock 0
		set interp [dict get $::session($sessionid) interp]
		$interp eval namespace delete ::wtk
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp eval wtk::init sendto
	}
	
	#update the clients cookie, todo: should do this periodically
	set msgq "(function () { document.cookie= 'wtksess=${sessionid};expires=0;path=/;' })();"
	dict set ::session($sessionid) msgq $msgq
	
	#pass in the server header vars first
	$interp eval [list set ::reqdata $data]
	#now source the app script
	if {[catch {$interp eval source $script}]!=0} {puts $::errorInfo}
	
	if {[file exists favicon.ico]} {
		set link "<link href='data:image/x-icon;base64,%%%BASE64ICO%%%' rel='icon' type='image/x-icon' />"
		set favicon [string map "%%%BASE64ICO%%% [binary encode base64 [filecontents favicon.ico]]" $link]
	} else {
		set favicon ""
	}
	return [string map "%%%SESSIONID%%% $sessionid %%%FAVICON%%% \"$favicon\"" [filecontents $webpage]]








|















|



|




|








202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241

			incr ::sessioncounter
			set isnewsess 1
		} else {
			#reuse existing session
			set sessionid $wtksess
		}
	}

	if {$isnewsess} {
		set interp [interp create]
		dict set ::session($sessionid) interp $interp
		dict set ::session($sessionid) sock $sock
		dict set ::session($sessionid) wsock 0
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp alias sendto toclient $sessionid
		$interp eval wtk::init sendto
	} else {
		dict set ::session($sessionid) wsock 0
		set interp [dict get $::session($sessionid) interp]
		$interp eval namespace delete ::wtk
		if {[catch {$interp eval source lib/wtk-base.tcl}]!=0} {puts $::errorInfo}
		$interp eval wtk::init sendto
	}

	#update the clients cookie, todo: should do this periodically
	set msgq "(function () { document.cookie= 'wtksess=${sessionid};expires=0;path=/;' })();"
	dict set ::session($sessionid) msgq $msgq

	#pass in the server header vars first
	$interp eval [list set ::reqdata $data]
	#now source the app script
	if {[catch {$interp eval source $script}]!=0} {puts $::errorInfo}

	if {[file exists favicon.ico]} {
		set link "<link href='data:image/x-icon;base64,%%%BASE64ICO%%%' rel='icon' type='image/x-icon' />"
		set favicon [string map "%%%BASE64ICO%%% [binary encode base64 [filecontents favicon.ico]]" $link]
	} else {
		set favicon ""
	}
	return [string map "%%%SESSIONID%%% $sessionid %%%FAVICON%%% \"$favicon\"" [filecontents $webpage]]
︙︙
290
291
292
293
294
295
296
297
298

if {[llength $::argv] > 0} {set ipaddress [lindex $::argv 0]}
if {[llength $::argv] > 1} {set port [lindex $::argv 1]}

# start everything up
httpd listen 9001 webhandler $ipaddress
puts stdout "Started wtk demo on http://$ipaddress:$port"
vwait forever










<
<

291
292
293
294
295
296
297



if {[llength $::argv] > 0} {set ipaddress [lindex $::argv 0]}
if {[llength $::argv] > 1} {set port [lindex $::argv 1]}

# start everything up
httpd listen 9001 webhandler $ipaddress
puts stdout "Started wtk demo on http://$ipaddress:$port"
vwait forever
Fossil version 2.26 [935cd45f03] 2025-02-06 15:57:56