SR Technology WTK Repo
Artifact Content
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.

Artifact 6c57e1d1bd37e157d2925b03ebd0076e9440b0bb:

#!/usr/bin/env netbin64

#!/usr/bin/env tclsh8.6

# Main application, which runs a webserver and is responsible for creating new
# application instances in response to client (web) connections, and acts as an ongoing
# communication middle man between each instance and the clients.
# Each instance is associated with a separate Tcl interpreter. Instances are
# identified using a "sessionid".  The global array "sessions" holds information
# on each session, including the interpreter, messages queued up to send to the
# client, etc.
# For this demo program, communication between client and server here is via a very
# simple two connection AJAX model (one for the client sending messages via /wtkcb.html,
# and one for the client receiving messages via /wtkpoll.html). Importantly, it
# doesn't matter what the communication mechanism is (this one is simple but very weak),
# and could be replaced by anything, e.g. WebSockets,, procedure calls
# to another part of the same program, etc.  As far as wtk is concerned, everything
# is hidden behind the "fromclient" and "toclient" API's, whatever their implementation.

# For demo purposes, include our variation of the minihttpd.tcl, which generates
# callbacks on every received URL.
package require sha1
source lib/httpd.tcl

set ::events_on_stdout 0

proc bgerror {message} {puts stderr "bgerror: $message\n$::errorInfo"}
set ::log log
proc log {args} {puts $args}

proc ws_send {sock {msg ""} {type text} {final 1}} {
	# Compute the opcode.  The opcode is zero for continuation frames.
	upvar #1 fragment fragment
	if {[info exists fragment]} {
		set opcode 0
	} else {
		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"        {httpd return $sock [filecontents $url] -mimetype "text/css"}
                        "*.html"       {httpd return $sock [filecontents $url] -mimetype "text/html"}
			"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

# newsession -- Create a new application instance
# This is called when a client first loads one of our 'application' pages.  We create a new
# application instance (interpreter), load and initialize "wtk" in that interpreter, and then
# load in the Tcl script for the application we're running.  We return a HTML page that will
# load up the client side of wtk and cause the browser to initiate a connection back to the
# server. Notably, this page includes the 'sessionid' we've generated for the application
# instance, which is unique to each client.

proc newSession {sock script webpage data} {
	#check for existing session in client cookie
	#retrieve the validation cookie
	set wtksess ""
	set isnewsess 0
	if {[dict exists $data mime,cookie]} {
		set wtksess [lindex [split [lsearch -inline -glob [dict get $data mime,cookie] wtksess=*] =] end]
	if {$wtksess == "" || $wtksess == "undefined"} {
		#create new session
		set sessionid [clock milliseconds]
		incr ::sessioncounter
		set isnewsess 1
	} else {
		if {![info exists ::session($wtksess)]} {
			#session no longer exists on server, issue new one
			set sessionid [clock milliseconds]
			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]]

# fromclient -- Receive a message from a web client and route it to the correct app instance
# This is called when the client wants to send its application instance a message (via
# the /wtkcb.html callback in this case), typically an event like a button press.
# We invoke the '::wtk::fromclient' routine in the instance's interpreter to process it.
proc fromclient {sessionid cmd} {puts "CLIENT: $cmd"; [dict get $::session($sessionid) interp] eval ::wtk::fromclient [list $cmd]}

# toclient -- Send Javascript commands from an app instance to the web client
# This is called when the application instance wants to send its client a message,
# in the form of a Javascript command.  The message is queued and the actual
# sending is taken care of by the next routine.
proc toclient {sessionid cmd} {
	if {[dict get $::session($sessionid) wsock] != 0} {
		if {$::events_on_stdout} {puts "WSSERVER: $cmd"}
		dict append ::session($sessionid) msgq $cmd
		ws_send [dict get $::session($sessionid) wsock] $cmd
	} else {
		if {$::events_on_stdout} {puts "SERVER: $cmd"}
		dict append ::session($sessionid) msgq $cmd

# sendany -- Deliver messages to the client queued by 'toclient'
# When we receive a client poll (/wtkpoll.html) this routine is called. If we have messages
# queued up for the client we immediately send them; this completes the poll and the client
# will then initiate a new poll. If we don't have any messages queued up at the time we receive
# the poll request, we periodically call ourselves asynchronously until we do have messages
# to send back.  Note that we don't handle timeouts, disconnects, etc.
proc sendany {sock sessionid} {
	catch {after cancel $::cancel($sock)}
	if {[dict get $::session($sessionid) msgq]!=""} {
		httpd return $sock [dict get $::session($sessionid) msgq] -mimetype "text/javascript"
		dict set ::session($sessionid) msgq ""
		return 1
	} else {
		set ::cancel($sock) [after 100 sendany $sock $sessionid]
		return 0

set ipaddress localhost
set port 9001
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