#!/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 "" 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