CloudTk

noVNC

CloudTk website

demonstrated here

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.4
}

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

         foreach var {Xstate(XvncClose) Xstate(WmClose) Xstate(TkClose)} {
               if {[info exists $var]} {
                   if {[regexp {^(EXITED|KILLED)} $Xstate(XvncClose)]} {
                       set Xstate(XvncClose) 1
                       set Xstate(WmClose) 1
                       set Xstate(TkClose) 1
                   }
               } else {
                   set Xstate(XvncClose) 1
                   set Xstate(WmClose) 1
                   set Xstate(TkClose) 1
               }
         }
         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 &]
     }
}

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References