A Summary of the application

It is based on WebSockit2me [http://wiki.tcl.tk/41298] - a TCP to WebSocket gateway that uses a noVNC to display Tk applications in modern Web Browser. It runs on Linux and requires an Xvnc server to be loaded. Tk applications are listed on a web page. TclHttpd dynamically launches an Xdisplay via Xvnc and then starts a window manager and launches the Tk application. 

It runs on Linux x86_64 or arm(Raspberry Pi) with Tcl/Tk version 8.6.

Please refer to the CloudTk website [http://172.104.5.86] where you can download the Starkit. Also if you go to the following url [http://172.104.5.86:5443/cloudtk/] you can see an example web page which has some Tk Applications listed from this wiki.

Below are the two main files in the custom directory of TclHttpd. CloudTk.tcl controls the websocket to TCP gateway. Xdisplay.tcl uses "Standalone bgexec" [https://wiki.tcl.tk/13400] to launch an Xdisplay via Xvnc, the matchbox window manager [https://www.yoctoproject.org/tools-resources/projects/matchbox] and the Tk application.



**** CloudTk.tcl ****


===
===
======
# Copyright (c) 2017 Jeff Smith
#
# See the file "license.terms" of TclHttpd for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# I made a few modifications to the Websocket library to make it work with TclHttpd.
#
#       1. In the procedure ::websocket::takeover changed the following line from
#          fconfigure $sock -translation binary -blocking on
#          to
#          fconfigure $sock -translation binary -blocking off
#
#
#       2. In the procedure ::websocket::Receiver changed the following line from
#          binary scan $dta Iu mask
#          to
#          binary scan $dta I mask
#
#       Without this change the intial handshake with the VNC or Telnet Server
#       was intermittent ie. did not connect.
#
#       So make the above modifications and then save the following to
#       WebSocketTCP-gateway.tcl and drop in the custom directory.
#

# Setup the AuthUserFile and copy the default webmaster credentials to the file
# outside the Starkit.

if {![file exists $Config(AuthUserFile)]} {
    set fd [open $Config(AuthUserFile) w]
    puts $fd "webmaster:$authdefault(user,webmaster)"
    close $fd
    unset fd
}


# If the user is Upgrading noVNC by creating a noVNC directory outside the Starkit,
# remap this new directory via Doc_AddRoot.
#
# The Config(starkitTop) array variable is defined in the main.tcl file of the
# Starkit and is used by the startup scripts of TclHttpd to define certain paths.

if {[file isdirectory [file join [file dirname $Config(starkitTop)] noVNC]]} {
    Doc_AddRoot /kanaka/noVNC [file join [file dirname $Config(starkitTop)] noVNC]
} else {
    Doc_AddRoot /kanaka/noVNC [file join $Config(starkitTop) noVNC-master]
}

Mtype_Add .svg image/svg+xml

Url_AccessInstallPrepend ::cloudtk::AccessHook

Url_PrefixInstall /cloudtk [list ::cloudtk::Start /cloudtk]

        package require websocket

namespace eval ::cloudtk {
         # ensure ::cloudtk namespace exists
set ::Config(cloudtkVersion) 0.1.3
}

proc ::cloudtk::Start {prefix sock suffix} {
        upvar #0 Httpd$sock data
        variable Target

   set suffix [Url_PathCheck [string trimleft $suffix /]]
   if {![regexp {.*(/)$} $suffix _ slash]} {
     set slash ""
   }

if {[info exists ::Session:$suffix]} {
         upvar #0 Session:$suffix state

    if { $state(type) == {WsActive} } {
         Redirect_Self /cloudtk/
    } else {
         return [::cloudtk::Session $sock $suffix]
    }
}


set noVNCpath {/kanaka/noVNC/vnc.html?path=cloudtk/$session&resize=remote&autoconnect=true}

switch -- $suffix {
             "VNC" {
                     ::cloudtk::Dynamic $sock $noVNCpath
                   }
          default {
                   append pagehtml "<p>\n"
                   append pagehtml "Enter the Tk Application you wish to launch.\n<p>\n"
                   append pagehtml "<form action=$data(prefix)/VNC method=POST>\n"
                   append pagehtml "<input type=hidden name=session value=new>\n"
                   append pagehtml "<table>\n"
                   foreach d [glob [file join [file dirname $::Config(starkitTop)] Tk]/*] {
                   set Tkapp [file tail $d]
                   append pagehtml [::html::row $Tkapp "<input type=radio [html::radioValue Tk $Tkapp]>"]\n
                   }
#                   append pagehtml [::html::row "VNC Host" "<input type=text [html::formValue TCPhost]>"]\n
#                   append pagehtml [::html::row "VNC Port" "<input type=text [html::formValue TCPport]>"]\n
                   append pagehtml "</table>\n<p>\n<p>\n"
                   append pagehtml "<input type=submit>\n<p>\n</form>\n"
                   append pagehtml "</body>\n</html>"
                   Httpd_ReturnData $sock text/html "[::mypage::header "Tk Application"] $pagehtml [mypage::footer]"
                  }
          }
}

# ::cloudtk::Session --
#       This procedure control access to the websocket to TCP gateway via a Session ID
#       via a Url query parameter.

proc ::cloudtk::Session {sock session} {
        upvar #0 Httpd$sock data

# To get started register the socket as a websocket server.

        ::websocket::server $sock

# The callback procedure when a message/data is present.

        ::websocket::live $sock /cloudtk [list ::cloudtk::Gateway $session]

# Test the Http headers via data(headerlist) to see if it is a websocket request.

        set wstest [::websocket::test $sock $sock /cloudtk $data(headerlist) $data(query)]

# If ::websocket::test returns 1 it's a valid websocket request so suspend the Http request
# in TclHtppd. Let the websocket library return the correct Http headers via the
# ::websocket::upgrade and take control.

        if {$wstest == 1} {
            Httpd_Suspend $sock 0
            ::websocket::upgrade $sock
        } else {
            Httpd_ReturnData $sock text/html "Not a valid Websocket connection!"
        }
}


# ::cloudtk::Gateway --
#       This procedure is called when the server
#       can read data from the client
#
# Arguments: appended to the callback procedure by the Websocket library.
#       sock    The socket connection to the client
#       type    Type of message either:
#               request (initial connection generated by the websocket library.)
#               close
#               disconnect
#               binary
#               text
#       msg     message or data
#

proc ::cloudtk::Gateway {session sock type msg} {
         upvar #0 Session:$session state

# Uncomment the following line to view what's being sent from the client.

#puts "Gateway sock=$sock type=$type msg=$msg"


# In Tcl Websocket Library in tcllib there was a change in the type of connection label. In
# Version 1.3.1 the intial connection type was "request" in Version 1.4 it changed to "connect".
# Have kept both incase a different version is used.

          switch $type {
                request {
                         set state(type) WsActive
                         return [::cloudtk::SocketTCP $sock $session $state(TCPhost) $state(TCPport)]
                        }
                connect {
                         set state(type) WsActive
                         return [::cloudtk::SocketTCP $sock $session $state(TCPhost) $state(TCPport)]
                        }
                close { return }
                disconnect {
                            Xdisplay_Close $state(Xdisplay) Xvnc
                            close $state(TCPsock)
                            Session_Destroy $session
                            unset ::Httpd$sock
                            unset ::websocket::Server_$sock
                            return
                           }
                binary {
                        puts -nonewline $state(TCPsock) $msg
                        return
                       }
                text {
                      return
                }
        }
}

# ::cloudtk::SocketTCP --
#       This procedure connect via socket -async to the TCP host port.

proc ::cloudtk::SocketTCP {sock session TCPhost TCPport} {
      upvar #0 Session:$session state


         set state(TCPsock) [socket -async $TCPhost $TCPport]
         fconfigure $state(TCPsock) -translation binary -blocking off -buffering none
         fileevent $state(TCPsock) r [list ::cloudtk::ReceiveTCP $sock $session $state(TCPsock)]
}

# ::cloudtk::ReceiveTCP --
#       This procedure receives data on the TCP socket and then
#       resends it on the websocket via ::websocket::send

proc ::cloudtk::ReceiveTCP {sock session TCPsock} {
      upvar #0 Session:$session state

     set error [fconfigure $state(TCPsock) -error]

     if {$error ne ""} {
         ::websocket::close $sock
     } elseif {[eof $state(TCPsock)]} {
         ::websocket::close $sock
     } else {
         ::websocket::send $sock binary [read $state(TCPsock)]
     }
}

# ::cloudtk::Auth --
#       This procedure is used in the callback of the .tclaccess
#       files.

proc ::cloudtk::Auth {sock realm user pass} {

     set file [file join $::Config(docRoot) cloudtk .tclaccess]
     set ::auth${file}(htaccessp,userfile) $::Config(AuthUserFile)
     # now check the Basic credentials
     set crypt [AuthGetPass $sock $file $user]
     set salt [string range $crypt 0 1]
     set crypt2 [crypt $pass $salt]
     if {[string compare $crypt $crypt2] != 0} {
         return 0        ;# Not the right password
     } else {
         return 1
     }
}

# ::cloudtk::AccessHook --
#       This procedure is used via Url_AccessInstallPrepend to change
#       the default behaviour of the authentication. It check if the
#       the url starts with /cloudtk or /kanaka and allows access
#       based on what is set in the AuthTargetFile.txt file.

proc ::cloudtk::AccessHook {sock url} {
    global Doc
    upvar #0 Httpd$sock data
    variable Target

    if {![string equal [file mtime $Target(AuthTargetFile,file)] $Target(AuthTargetFile,mtime)]} {
        ::cloudtk::AuthTarget
    }

    # Make sure the path doesn't sneak out via ..
    # This turns the URL suffix into a list of pathname components

    if {[catch {Url_PathCheck $data(suffix)} data(pathlist)]} {
        Doc_NotFound $sock
        return denied
    }

    # Figure out the directory corresponding to the domain, taking
    # into account other document roots.

    if {[regexp {^(/cloudtk|/kanaka|/favicon.ico|/images)} $url]} {
        set directory [file join $Doc(root,/) cloudtk]

        set suffix [Url_PathCheck [string trimleft $data(suffix) /]]
        if {![regexp {.*(/)$} $suffix _ slash]} {
            set slash ""
        }
        if {$Target(AuthTargetFile,VNC) == 0} {
            if {[regexp {^(/cloudtk/|/kanaka/noVNC|/favicon.ico|/images/)} $url]} {
                return ok
            } elseif {[info exists ::Session:$suffix]} {
                return ok
            }

        }

        # Look for .tclaccess file in cloudtk directory.
        # This controls access to cloudtk and kanaka
        # directories.
        set cookie [Auth_Check $sock $directory ""]

        # Finally, check access

        if {![Auth_Verify $sock $cookie]} {
            return denied
        } else {
            return skip
        }
     } elseif {[regexp {^(/debug|/status)} $url]} {
               return skip
     } elseif {[regexp {^(/)} $url]} {
           if {$Target(AuthTargetFile,Website) == 0} {
               return ok
           } else {
               return skip
           }
     } else {
        return skip
     }
}


# ::cloudtk::AuthTarget --
#       This procedure sets up  the Auth Target file and gets its contents
#       into an array. If the file doesn't exist it sets some defaults.

proc ::cloudtk::AuthTarget {} {
     variable Target

     set Target(AuthTargetFile,file) [file join [file dirname $::Config(starkitTop)] auth AuthTarget.txt]

     if {![file exists $Target(AuthTargetFile,file)]} {
         set fd [open $Target(AuthTargetFile,file) w]
         puts $fd "VNC 0"
         puts $fd "Website 0"
         close $fd
         unset fd
         set Target(AuthTargetFile,VNC) "0"
         set Target(AuthTargetFile,Website) "0"
         set Target(AuthTargetFile,mtime) [file mtime $Target(AuthTargetFile,file)]
     } else {
         set Target(AuthTargetFile,mtime) [file mtime $Target(AuthTargetFile,file)]
         set fd [open $Target(AuthTargetFile,file) r]
         while {[gets $fd line] >= 0} {
                set Target(AuthTargetFile,[lindex $line 0]) "[lindex $line 1]"
         }
         close $fd
         unset fd
     }
}

# ::cloudtk::Dynamic ---
# This procedure is run when a Host and Port is configured in the form. It checks
# to make sure that the previous page was a referer page from same server or
# source you configure.
# It checks a valid Session ID is created and not a crafted Session ID.
# Tests the Host and Port are valid before establishing the WebSocket and
# the TCP connection.

proc ::cloudtk::Dynamic {sock urlRedirect} {
        upvar #0 Httpd$sock data


                set session [Session_Match [Url_DecodeQuery $data(query)] WsInit {} 0]

                if {$session eq ""} {
                    Httpd_ReturnData $sock text/html "<br><h2><b>Error message = Not a valid Session ID</b></h2>"
                } else {
                    upvar #0 Session:$session state
#                    Xdisplay_SessionReap 90 WsInit

                    foreach {name value} [Url_DecodeQuery $data(query)] {
                             if {[string match $name session] == 1 } {
                                 continue
                             } else {
                                 set state($name) $value
                             }
                    }
                    set state(Xdisplay) [Xdisplay_Start 10 $session]
                    set state(TCPhost) 127.0.0.1
                    set state(TCPport) [expr {5900 + $state(Xdisplay)}]
                    Redirect_Self [subst $urlRedirect]
                }
}

# ::cloudtk::TkPool --
#       This procedure sets up  TkPool in the Tk directory. It copies 2 files
#       TkStartup.tcl and TkPool.tcl from the TclHttpd's custom directory into
#       Tk/TkPool direcory of the Starkit.

proc ::cloudtk::TkPool {} {

     set TkPool(dir) [file join [file dirname $::Config(starkitTop)] Tk TkPool]
     set TkPool(custom,file) [file join $::Config(home) ../custom]/TkPool.tcl.custom
     set TkPool(custom,start) [file join $::Config(home) ../custom]/TkStartup.tcl.custom
     set TkPool(Tk,file) $TkPool(dir)/TkPool.tcl
     set TkPool(Tk,start) $TkPool(dir)/TkStartup.tcl

     if {![file isdirectory $TkPool(dir)]} {
         file mkdir $TkPool(dir)
         file copy -force $TkPool(custom,file) $TkPool(Tk,file)
#         file copy -force $TkPool(custom,start) $TkPool(Tk,start)
         set fd [open $TkPool(Tk,start) w]
         set in [open $TkPool(custom,start) r]
         set IN [read $in]
         close $in
         append IN "source $TkPool(Tk,file)\n"
         append IN "\}"
         puts $fd $IN
         close $fd
     } else {
         return
     }
}

# Generate the Auth file.
::cloudtk::AuthTarget

# Generate TkPool
::cloudtk::TkPool

======




**** Xdisplay.tcl ****

======

# Copyright (c) 2017 Jeff Smith
#
# See the file "license.terms" of TclHttpd for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

package require bgexec

# Xdisplay_Start --
#
# The purpose of the below procedure is to manage the X display number used
# when an Xvnc server is launched. Once the X display is lauched the Tk
# application and a Window Manager(if needed) is started that use the same X display.
# It also does checks to make sure that it won't use an active X display
# otherwise Xvnc won't start.
#
# Bgexec is used to launch the Xvnc server, Tk application and Window
# Manager as a background process.

proc Xdisplay_Start {{Xdisplay 1} session} {
     upvar #0 Session:$session state

     set Xincr 1
     while {$Xincr == 1} {
            if {[info exists ::X${Xdisplay}] || [file exists /tmp/.X${Xdisplay}-lock] || [file exists /tmp/.X11-unix/X$Xdisplay]} {
                incr Xdisplay
            } else {
                set ::X${Xdisplay}(Session) Session:$session
                set state(TCPhost) 127.0.0.1
                set state(TCPport) [expr {5900 + $Xdisplay}]
                set ::X${Xdisplay}(Start) [clock seconds]
                set ::X${Xdisplay}(XvncClose) 0
                trace variable ::X${Xdisplay}(XvncClose) aw "Xdisplay_Close $Xdisplay Xvnc"
                set ::X${Xdisplay}(TkClose) 0
                trace variable ::X${Xdisplay}(TkClose) aw "Xdisplay_Close $Xdisplay Tk"
                set ::X${Xdisplay}(WmClose) 0
                trace variable ::X${Xdisplay}(WmClose) aw "Xdisplay_Close $Xdisplay Wm"
                set ::X${Xdisplay}(XvncPid) [bgexec ::X${Xdisplay}(XvncClose) -killsignal SIGTERM -linebuffered true -onerror "Xdisplay_XvncStart $Xdisplay $session" /usr/bin/Xvnc :$Xdisplay -localhost -desktop $state(Tk) SecurityTypes=None &]
                set Xincr 0

            }
     }
     Xdisplay_Reap
     Xdisplay_SessionReap 90 WsInit
     return $Xdisplay
}


# Xdisplay_Close --
#
# The purpose of the below procedure is to close all the processes associated
# with an X display. This is called once the process dies or we kill it
# and a trace variable is triggered. Setting the trace variable will kill
# the process under the control of bgexec.

proc Xdisplay_Close {Xdisplay type args} {
          upvar #0 X$Xdisplay Xstate

     switch $type {
                   Xvnc  {
                          set Xstate(TkClose) 1
                          set Xstate(WmClose) 1
                          set Xstate(XvncClose) 1
                   }
                   Tk {
                          set Xstate(WmClose) 1
                          set Xstate(XvncClose) 1
                   }
                   Wm {
                          set Xstate(TkClose) 1
                          set Xstate(XvncClose) 1
                   }
     }
}


# Xdisplay_Reap --
#
# The purpose of the procedure below is to clean up any X display variable
# that still exist in TclHttpd but no longer have an active X display. This
# produre is called after a new X display is started in Xdisplay_Start

proc Xdisplay_Reap {} {

     foreach xd [info globals X*] {
         upvar #0 $xd Xstate
         if { $Xstate(TkClose) && $Xstate(WmClose) && $Xstate(XvncClose) } {
              Stderr "Reaping Xdisplay variable $xd"
              unset Xstate
         }
     }
}


# Destroy all sessions older than a certain age (in seconds)
#    age:  time (in seconds) since the most recent access
#    type: a regexp to mach session types with (defaults to all)

proc Xdisplay_SessionReap {age {type .*}} {
    foreach id [info globals Session:*] {
        upvar #0 $id session
        set old [expr {[clock seconds] - $age}]
        if {[regexp -- $type $session(type)] && $session(current) < $old} {
            catch {interp delete $session(interp)}
            Stderr "Reaping session $id"
            if { [info exists session(TCPport)] } {
                 set Xdisplay [expr {$session(TCPport) - 5900}]
                 Xdisplay_Close $Xdisplay Xvnc
            }
            unset session
        }
    }
}




proc Xdisplay_XvncStart {Xdisplay session data} {
             upvar #0 Session:$session state

# Wait until Xdisplay has started before loading Tk app and Window Manager
     if {[string match "*Listening for VNC connections on * port *" $data]} {
         set ::X${Xdisplay}(WmPid) [bgexec ::X${Xdisplay}(WmClose) -killsignal SIGTERM /usr/bin/matchbox-window-manager -display :$Xdisplay &]
         set ::X${Xdisplay}(TkPid) [bgexec ::X${Xdisplay}(TkClose) -killsignal SIGTERM [info nameofexecutable] [file join [file dirname $::Config(starkitTop)] Tk $state(Tk) TkStartup.tcl] -display :$Xdisplay &]
     }
}

======

<<categories>>TclHttpd