#!/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, socket.io, 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