http://127.0.0.1:8015

# I made a few modifications to the Websocket library to make it work with Tclhttpd.
#
#       1. In the procedure ::websocket::test changed the following line from
#          [string equal -nocase $v "upgrade"] } {
#          to
#          [string compare -nocase $v "*upgrade*"] } {
#          Most browsers send the header "Connection: Upgrade" but Firefox sends
#          "Connection: keep-alive, Upgrade"
#
#       2. In the procedure ::websocket::takeover changed the following line from
#          fconfigure $sock -translation binary -blocking on
#          to
#          fconfigure $sock -translation binary -blocking off
#
#       3. 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 symptoms were intermittent starting of TclRFB 
#          server.
#
# So make the above modifications and then save the following to 
# tclRFB-novnc.tcl and drop in the custom directory.
#

Url_PrefixInstall /novnc [list ::novnc::domain /novnc]

package require websocket

namespace eval ::novnc {
  # ensure ::novnc namespace exists
}

namespace eval ::rfbcounter {
         # ensure ::rfbcounter namespace exists
}

proc ::novnc::domain {prefix sock suffix} {
upvar #0 Httpd$sock data

# Use the Session Module in TclHttpd to create a slave interpreter to run the
# TclRFB package in but rename certain commands to redirect the I/O to the webSocket library.

set session [Session_Create Rfb 0]


# 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 /novnc [list ::novnc::TclRFB $session]

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

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

# If ::websocket::test returns 1 it's a valid websocket request so suspend the Http request
# in TclHtppd. Start the TclRFB server in its own Slave Interpreter. 
# Let the websocket library return the correct Http headers via the ::websocket::upgrade 
# procedure and take control.

if {$wstest == 1} { 
            Httpd_Suspend $sock 0
            ::rfbcounter::Setup $sock $session rfbcounterNovnc.tcl -clock 1 000000 0000ff
            ::websocket::upgrade $sock
        } else {
            Httpd_ReturnData $sock text/html "Not a valid Websocket connection!" 
            Session_Destroy $session
        }
}


# ::novnc::TclRFB --
#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 ::novnc::TclRFB {session sock type msg} {
       upvar #0 Session:$session state
       set interp $state(interp)

  switch $type { 
                request { 
                         set rfbClientAddr [lindex [fconfigure $sock -peername] 0]
                         set rfbClientPort [lindex [fconfigure $sock -peername] 2]
                         $interp eval ::rfb::AcceptServerSocket $sock $rfbClientAddr $rfbClientPort
                        }
                close { 
                        return 
                       } 
                disconnect { 
                            Session_Destroy $session
                            unset ::Httpd$sock
                            return
                            }   
                binary { 
                        set state(lwsockmsg) 1
                        set state(wsockmsg) $msg
                        while {$state(lwsockmsg) > 0} {
                               $interp eval ::rfb::ServerConnectionStateMachine $sock
                             } 
                        return
                       }
                text { 
                      return 
                     } 
        }
}


# ::rfbcounter::Setup --
#       This procedure is called just before the WebSocket Library takes over the socket. 
#       It sets up the rfb server to run using the same event loop as Tclhttpd and the 
#       WebSocket Library before data is transferred. We want to run rfbcounterNovnc.tcl
#       in its own slave interpreter and this way we can capture the I/O by aliasing commands
#       and redirecting them to the WebSocket Library.
#
# Arguments: 
#       sock    The socket connection to the client
#       session The session used to create the interp 
#       sfile   The source file in the bin directory.
#       args    The arguments if rfbcounter.tcl was run on the command line.
#

proc ::rfbcounter::Setup { sock session sfile args } {
       upvar #0 Session:$session state
       set interp $state(interp)

      # Following taken from httpd.tcl for getting these variables into
      # a slave interpreter.
      #
      # Transfer the scalar global variables

      foreach var {::v ::auto_path} {
         $interp eval [list set $var [set $var]]
      }

      # Renaming commands and aliasing in the Slave Interpreter
      # to capture the socket I/O.

      interp eval  $interp {rename puts real_puts}
      interp alias $interp puts {} ::rfbcounter::Puts $interp
      interp eval $interp {rename read real_read}
      interp alias $interp read {} ::rfbcounter::Read $sock $session 
      interp eval $interp {rename close real_close}
      interp alias $interp close {} ::rfbcounter::Close $interp
      interp eval $interp {rename fconfigure real_fconfigure}
      interp alias $interp fconfigure {} ::rfbcounter::Fconfigure $interp
      interp eval $interp {rename socket real_socket}
      interp alias $interp socket {} ::rfbcounter::Socket $interp $sock
      interp eval $interp {rename fileevent real_fileevent}
      interp alias $interp fileevent {} ::rfbcounter::Fileevent $interp  
      interp share {} $sock $interp


      interp eval $interp "set argc [llength $args]"
      set cmdargv "set argv [list $args]"
      interp eval $interp $cmdargv
      $interp eval [list set sock $sock]
      $interp eval [list set tclhttpdport [lindex [fconfigure $sock -sockname] 2]]
      set cmd [list source [file join $starkit::topdir bin $sfile]]
      $interp eval $cmd 
}

proc ::rfbcounter::Puts { interp args } {

     if {[string match "-nonewline" [lindex $args 0]]} {
         set flag -nonewline
         set args [lrange $args 1 end]
     } else {
         set flag ""
     }
     if {[llength $args] == 1} {
         set chan stdout
         return [$interp eval real_puts $chan $args]
     } elseif {[llength $args] == 2} {
               if {[string match "sock*" [lindex $args 0]]} {
                   set sock [lindex $args 0]
                   set msg [lindex $args 1]
                  ::websocket::send $sock binary $msg 
               } else {
                   return [$interp eval real_puts $flag $args]
               }
      } else {
         return [$interp error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""]
      }
}

proc ::rfbcounter::Read {sock session args} {
       upvar #0 Session:$session state
       set interp $state(interp)

      if { [llength $args] == 2 && [string match "sock*" [lindex $args 0]] } {
            set range [expr [lindex $args 1]-1]
            set wsockdata [string range $state(wsockmsg) 0 $range]
            set state(wsockmsg) [string range $state(wsockmsg) [lindex $args 1] end] 
            set state(lwsockmsg) [string length $state(wsockmsg)]
            return $wsockdata
      } else {
           return [$interp eval real_read $args]
      }
}

proc ::rfbcounter::Close {interp args} {
      if {[string match "sock*" [lindex $args 0]]} {
          ::websocket::close $sock
      } else {
          return [$interp eval real_close $args]
      }
}

proc ::rfbcounter::Fconfigure {interp args} {
      if {[string match "-buffering" [lindex $args 1]]} {
          return
      } else {
          return [$interp eval real_fconfigure $args]
      }
}

proc ::rfbcounter::Socket {interp sock args} {
      if {[string match "-server" [lindex $args 0]]} {
          return $sock
      } else {
          return [$interp eval real_socket $args]
      }
}

proc ::rfbcounter::Fileevent {interp args} {
      return 
}

#    This is a slightly modified rfbcounter.tcl file that
#    was originally shipped with TclRFB as a demo. It
#    allows TclRFB to run with TclHttpd, WebSocket  and the
#    noVNC client. Save this to rfbcounterNovnc.tcl and drop in
#    the bin directory of TclHttpd.


package require tclRFB

set ::rfb::rfb($sock,clientBEIfLittle) 1

# TclRFB - rfbcounter.tcl: Counter/clock RFB server
# Determine command line arguments

set ndx 0

if {[string match {-clock} [lindex $argv 0]]} {
    set showClock 1
    incr ndx
} else {
    set showClock 0
}

if {[regexp -- {^[1-9]*[0-9]$} [lindex $argv $ndx]]} {
    set port [expr 5900 + [lindex $argv $ndx]]
    incr ndx
} else {
    puts {Incorrect command line options!!!}
    puts {rfbcouter.tcl [-clock] display-number [fg [bg]]}
    exit
}

if {$argc - $showClock > 1} {
    if {[regexp -- {^[0-9a-f]{6}$} [lindex $argv $ndx]]} {
set fg [lindex $argv $ndx]
incr ndx
    } else {
puts {Incorrect command line options}
puts {rfbcouter.tcl [-clock] display-number [fg [bg]]}
exit
    }
} else {
    set fg 000000
}

if {$argc - $showClock > 2} {
    if {[regexp -- {^[0-9a-f]{6}$} [lindex $argv $ndx]]} {
set bg [lindex $argv $ndx]
incr ndx
    } else {
puts {Incorrect command line options}
puts {rfbcouter.tcl [-clock] display-number [fg [bg]]}
exit
    }
} else {
    set bg ffffff
}

# Either TclDES or TclDESjr can be used with TclRFB.
# If you don't want to use VNC authentication, comment
# out the next line. See the ServerSetup proc also.
#package require tclDES
#package require tclDESjr


# sevenseg(number) {element element ... element}
set sevenseg(0) {a b c d e f}
set sevenseg(1) {b c}
set sevenseg(2) {a b d e g}
set sevenseg(3) {a b c d g}
set sevenseg(4) {b c f g}
set sevenseg(5) {a c d f g}
set sevenseg(6) {a c d e f g}
set sevenseg(7) {a b c}
set sevenseg(8) {a b c d e f g}
set sevenseg(9) {a b c d f g}

# sevenseg(element) {x y w h}
set sevenseg(a) {25 10 50 10}
set sevenseg(b) {75 20 10 50}
set sevenseg(c) {75 80 10 50}
set sevenseg(d) {25 130 50 10}
set sevenseg(e) {15 80 10 50}
set sevenseg(f) {15 20 10 50}
set sevenseg(g) {25 70 50 10}
set sevenseg(colonH) {0 40 10 10}
set sevenseg(colonL) {0 100 10 10}

# Procedure: ServerSetup - Set up the RFB server
# Inputs:
#   port - The port number for the RFB server.
#          (really TclHttpd port number)
# Output:
#   The socket handle for the created server.
#
# Effect:
#   The server awaits connection from one or more clients.
proc ServerSetup {port} {
    set optList [list serverVersionMajor 3]
    set optList [concat $optList [list serverVersionMinor 3]]
    set optList [concat $optList [list serverBPP 32]]
    set optList [concat $optList [list serverDepth 24]]
    set optList [concat $optList [list serverBE 1]]
    set optList [concat $optList [list serverTC 1]]
    set optList [concat $optList [list serverRmax 255]]
    set optList [concat $optList [list serverGmax 255]]
    set optList [concat $optList [list serverBmax 255]]
    set optList [concat $optList [list serverRshift 16]]
    set optList [concat $optList [list serverGshift 8]]
    set optList [concat $optList [list serverBshift 0]]
    set optList [concat $optList [list serverShared client]]
    set optList [concat $optList [list passwd {}]]
    set optList [concat $optList [list passfile /home/mcody/.vnc/passwd]]
    # If you don't want to use VNC authentication, replace
    # "[list scheme 2]" below with "[list scheme 1]".
#    set optList [concat $optList [list scheme 2]]
set optList [concat $optList [list scheme 1]]
    set optList [concat $optList [list width 600]]
    set optList [concat $optList [list height 150]]
    set optList [concat $optList [list name "TclRFB Clock Server $::sock"]]
    set optList [concat $optList [list updaterequest ProcessUpdateRequest]]
    set optList [concat $optList [list keyevent ProcessKeyEvent]]
    set optList [concat $optList [list pointerevent ProcessPointerEvent]]
    set optList [concat $optList [list servercuttext ProcessServerCutText]]
    # Initial last value will guarantee transmission of all characters.
    set optList [concat $optList [list lval -1]]
    return [::rfb::CreateServerSocket $port $optList]
}

# Procedure: ProcessUpdateRequest - Process the update request event that
#                                   comes fromt the client.
# Inputs:
#   sock   - Socket handle ID.
#   inc    - Flag for incremental update (1) or complete update (0).
#   x      - Coordinate of the lefthand side of the requested update region.
#   y      - Coordinate of the top side of the requested update region.
#   width  - Width of the requested update region.
#   height - Geight of the requested update region.
#
# Output:
#   1 - successful completion.
#
# Effect:
#   Appropriate frame buffer update message is sent to the client.
proc ProcessUpdateRequest {sock inc x y width height} {
    global showClock bg fg sevenseg

    # It appears noVNC doesn't take notice of the Server Endianness
    # and wants to have the colours in Little Endian order. 
    # (Not sure if this is the correct terminalogy. Instead of 
    # the colours in RGB order it wants BGR order.) Don't know
    # if the rfb($sock,clientBE) changes depending on the OS running
    # on the client machine but this should handle it if it does.

    if {$::rfb::rfb($sock,clientBEIfLittle)} {
        if {$::rfb::rfb($sock,clientBE) == 0} {
            set bgRed [string range $bg 0 1]
            set bgGreen [string range $bg 2 3]
            set bgBlue [string range $bg 4 5]
            set bg $bgBlue$bgGreen$bgRed
            set fgRed [string range $fg 0 1]
            set fgGreen [string range $fg 2 3]
            set fgBlue [string range $fg 4 5]
            set fg $fgBlue$fgGreen$fgRed
            set ::rfb::rfb($sock,clientBEIfLittle) 0
        } else {
            set ::rfb::rfb($sock,clientBEIfLittle) 0
        }
    }

    if {$::rfb::rfb($sock,state) eq {halted}} { return 0 }
    if {$showClock} {
# Get the current time
set cval [clock format [clock seconds] -format %H%M%S]
    } else {
set cval [string trimleft $::rfb::rfb($sock,lval) 0]
if {$cval != {}} {
    incr cval
} else {
    set cval 1
}
if {$cval > 1000000} {
    set cval 0
}
set cval [format %06d $cval]
    }

    # encodeList: {{2 x y w h bg {{x y w h fg} ... {x y w h fg}}} ... {2 x y w h bg {{x y w h fg} ... {x y w h fg}}}}
    if {![string match $::rfb::rfb($sock,lval) $cval] || !$inc} {
# start the RRE rectangle list with the background color
set i 0
foreach ndx {0 100 200 300 400 500} {
    set num [string index $cval $i]
    if {($num ne [string index $::rfb::rfb($sock,lval) $i]) || !$inc} {
set rreList [list 2 $ndx 0 100 150 $bg]
set rectList {}
foreach elm $sevenseg($num) {
    lappend rectList [concat $sevenseg($elm) $fg]
}
lappend rreList $rectList
lappend encodeList $rreList
    }
    incr i
}
if {$showClock} {
    # add the semicolons
    set rectList [list [concat $sevenseg(colonH) $fg]]
    lappend rectList [concat $sevenseg(colonL) $fg]
    lappend encodeList [list 2 195 0 10 150 $bg $rectList]
            lappend encodeList [list 2 395 0 10 150 $bg $rectList]
}

::rfb::SendFramebufferUpdate $sock $encodeList
set ::rfb::rfb($sock,lval) $cval
    } else {
# Send a dummy frame buffer update.
::rfb::SendFramebufferUpdate $sock {}
    }

    return 1
}

# Procedure: ProcessKeyEvent - Process the keyboard event that comes fromt the client.
# Inputs:
#   sock     - Socket handle ID.
#   downflag - Key depressed (1) or released (0).
#   keysym   - Keysym value.
#
# Output:
#   1 - Successful completion.
#
# Effect:
#   RFB message to ring the console bell is sent to the client.
proc ProcessKeyEvent {sock downflag keysym} {
    if {$downflag} {
::rfb::SendBell $sock
    }
    return 1
}

# Procedure: ProcessPointerEvent - Process the mouse pointer event that comes fromt the client.
# Inputs:
#   sock       - Socket handle ID.
#   buttonmask - States for the mouse buttons (1 - depressed, 0 - key released).
#   x          - Current x coordinate of the mouse cursor.
#   y          - Current y coordinate of the mouse cursor.
#
# Output:
#   1 - Successful completion.
#
# Effect:
#   RFB message to ring the console bell is sent to the client.
proc ProcessPointerEvent {sock buttonmask x y} {
    if {$buttonmask} {
::rfb::SendBell $sock
    }
    return 1
}

# Procedure: ProcessServerCutText - Process the cut buffer event that comes fromt the client.
# Inputs:
#   sock - Socket handle ID.
#   text - Cut buffer text sent by the client.
#
# Output:
#   1 - Successful completion.
#
# Effect:
#   RFB message to ring the console bell is sent to the client.
proc ProcessServerCutText {sock text} {
    ::rfb::SendBell $sock
    return 1
}

# Start up the server.
ServerSetup $tclhttpdport
# Wait until the server is shut down (Ctrl-C).
#set forever 0
#vwait forever

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