tclchannel

How to push a channel transformation for reads without using TclOO?


My question concerns pushing a channel transformation during a read. I coded this web socket (sort of a web socket) for the purposes of using a browser as the user interface and Tcl as the local server for a desktop application. So, it doesn't need to handle everything a "real" server would. I need to modify it to handle receiving a ping in the middle of a sequence of continuation frames; but that is not my question.

This code works in that it decodes the XOR frames. I've been using it for quite awhile as I've been working on the rest of the project and, now that I'm cleaning it up, I wondered about the manner in which the actual XOR decoding is performed. I've been reading in 4096 bytes at a time through a coroutine, then decoding and appending them to another variable. Could the decoding not be done in the read itself using a channel transformation?

You can ignore most of the code in proc ::WEBS::XOR_Read and the section directly related to this question is marked in comments with START OF THE QUESTION. I included it all because it is needed to run the example. At the bottom a text message is encoded with the given mask key, written to the write side of the pipe, and decoded on the read side.

My question is, How can I get the commented code, just under that labeled decode section, to push on a transformation just before the payload section of the frame is read to decode it as the channel is read and pop it when the read has completed? And is it worth it in terms of performance?

In the application, the read procedure in the namespace/command ChanTransform runs for about three bytes, decodes them incorrectly, and then freezes; but in this example code using the pipe, it appears that it doesn't run at all. It freezes also; but the after statement causes the script to terminate in two seconds. I probably shouldn't write freeze; for it must be waiting for more bytes to read. Do I need to use drain or set the limit? to return something other than -1?

All the examples I could find, including Ashok Nadkarni's text on Tcl, use TclOO (which I don't quite follow); and I just want to use the command and subcommands. However, I don't understand whether or not I'm supposed to invoke these subcommands or just push the cmdPrefix on the channel. And, I'm not sure how the ChanTransform read is to connect with the read $sock ... in the coroutine.

I'd appreciate any direction you may be able to provide. Thank you for considering my question.

namespace eval ::WEBS {}

namespace eval ChanTransform {
  proc initialize {handle mode} {
     return [list initialize drain limit? {*}$mode finalize]
  }
  proc drain {handle} {}
  proc limit? {handle} {
     return -1
  }
  proc read {handle bytes} { 
     variable mKey $::WEBS::mKey
     variable dataType $::WEBS::dataType
     namespace upvar ::WEBS offset offset
     if { [binary scan bytes cu enc] != 1} {
       # Can errors be thrown here.
       chan puts stdout {Error in read channel transformation.}
     }
     set raw_decoded "[expr {$enc ^ [lindex $mKey [expr {[incr offset] % 4}]]}] "
     return [binary format $dataType $raw_decoded]
  }
  proc finalize {handle} {
  }
  namespace export initialize drain limit? read finalize
  namespace ensemble create
}

proc ::WEBS::coread {sock id reqBytes} {
  set ::WEBS::encoded($id) {}
  set remBytes $reqBytes
  while {![chan eof $sock]} {
    yield
    append ::WEBS::encoded($id) [set data [read $sock $remBytes]]
    set remBytes [expr {$remBytes - [string length $data]}]
    if {$remBytes == 0} {
      return $reqBytes
    }
  }
  throw {COREAD EOF} "Unexpected EOF"
}


proc ::WEBS::XOR_Read {sock} {
  while {1} {
    set frame1 1
    set fin 0
    #set id [::WEBS::ReadId::getId]
    set id 1
    # Need the next line t track open ids in order to delete them
    # if left open following the sudden closing of a web socket.
#     dict set ::WEBS::socks $sock readIds\
#        [lappend [dict get $::WEBS::socks $sock readIds] $id]
    chan puts stdout "XOR read id: $id"
    while {$fin == 0} {
      if { [coread $sock $id 2] != 2
        || [binary scan $::WEBS::encoded($id) B16 bits] != 1
        || [scan $bits %1b%1b%1b%1b%4b%1b%7b fin rsv1 rsv2 rsv3 op m pl] != 7 } {
        chan puts stdout {Error in XOR_Read: failed to read or malformed read\
            of first 16 bits. Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { $rsv1 != 0 || $rsv2 != 0 || $rsv3 != 0 } {
        chan puts stdout {Error in XOR_Read: XOR frame from client includes\
            unexpected extensions. Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { $op == 8 } {
        # NOTE that testing only for op codes indicating not to
        # read payload. Client closing socket.
        chan puts stdout {Warning in XOR_Read: client closing socket\
            op code 8. Closing socket.}
        # WARNING Must stop the coroutine also; likely should
        # add this to WEBS_CloseSock
        ::WEBS::CloseSock $sock 0
        return
      } elseif { ($op > 2 && $op < 8) || $op > 10 } {
        # Client sent currently undefined codes.
        chan puts stdout {Error in XOR_Read: client sent undefined op codes.\
             Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { ($op == 9 || $op == 10) && $fin != 1 } {
        # If a PING or PONG and $fin indicates a continuation frame
        # is an error because max payload size if 127.
        chan puts stdout {Error in XOR_Read: client sent invalid payload\
            for PING or PONG. Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { !$frame1 && $op != 0  } {
        # All continuation frames must have an op code of 0.
        chan puts stdout {Error in XOR_Read: client sent invalid op code\
            for continuation frame. Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { $m != 1 } {
        chan puts stdout {Error in XOR_Read: XOR frame from client is\
            unmasked. Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { $pl == 0 || $pl > 127 } {
        # Evaluate initial payload length 7 bits.
        # If $pl not 0, 126, 127 then it is already correct.
        chan puts stdout {Error in XOR_Read: payload length is invalid.\
             Closing socket.}
        ::WEBS::CloseSock $sock 1
        return
      } elseif { $pl == 126
              && ([coread $sock $id 2] != 2
              || [binary scan $::WEBS::encoded($id) Su pl] != 1) } {
        chan puts stdout {Error in XOR_Read: wrong size returned\
            by binary scan Su.}
        WEBS_CloseSock $sock 1
        return
      } elseif { $pl == 127
             && ([coread $sock $id 8] != 8
             || [binary scan $::WEBS::encoded($id) Wu pl] != 1) } {
        chan puts stdout {Error in XOR_Read: wrong size returned\
            by binary scan Wu.}
        ::WEBS::CloseSock $sock 1
        return
      }

      # NOTE This spans all frames in a multi-frame message.
      # Also, continuation frames are indentified by
      if { $frame1 } {
        if { $op == 2 } {
          set dataType B*
        } else {
          set dataType cu*
        }
        set frame1 0
      }
      if { [coread $sock $id 4] != 4
        || [binary scan $::WEBS::encoded($id) cu4 mKey] != 1 } {
        chan puts stdout {Error in XOR_Read: failed to read the mask key.}
        ::WEBS::CloseSock $sock 1
        return
      }
      # NOTE In coread, ::WEBS::encoded($id) is set to {} at each
      # invocation. Thus, here, just reading all the data written
      # there; and doing so in 4096 bytes at a time. It appears to
      # work quickly; but have not read any messages over 1-2 MB.

      ########################################################
      # START OF THE QUESTION
      # The code below at least decodes the message, though it
      # could be better. I'd like to know if the channel trans-
      # formation can be used and how to get it started. It's
      # the commented block immediately below.
      ########################################################

      set offset -1
      while { [expr {$offset+1}] < $pl } {
        # This may be a stupid validation.
        set reqBytes [expr {min($pl-$offset-1,4096)}]
        if { [coread $sock $id $reqBytes] != $reqBytes } {
          chan puts stdout {Error in XOR_Read: failed reading payload.}
          ::WEBS::CloseSock $sock 1
          return
        }
        if { [binary scan $::WEBS::encoded($id) cu* enc] != 1} {
          chan puts stdout {Error in XOR_Read: wrong size returned\
              by binary scan cu. Closing socket.}
          ::WEBS::CloseSock $sock 1
          return
        }
        set raw_decoded {}
        foreach b $enc {
          # NOTE The space at the end is required or the subsequent
          # [binary format] appended to webSocket_decoded will fail.
          append raw_decoded \
             "[expr {$b ^ [lindex $mKey [expr {[incr offset] % 4}]]}] "
        }
        append ::WEBS::decoded($id) [binary format $dataType $raw_decoded]
      }

#       set ::WEBS::mKey $mKey
#       set ::WEBS::offset -1
#       set ::WEBS::dataType $dataType
#       set TransHandle${sock} [chan push $sock ChanTransform ]
#       #ChanTransform initialize TransHandle${sock} {read}
#       chan puts stdout "read [coread $sock $id $pl] bytes"
#
#       chan pop $sock
     }

    # Now, do something with the current message.
    # Note that op code 8 is handled in XOR_head.
    switch -- $op {
       9 {
           # Ping.
           chan puts stdout "Got pinged!"
           chan puts stdout "Message was: $::WEBS::decoded($id)"
           ::WEBS::Pong $sock $id
         }
      10 {
           # Pong.
           chan puts stdout "Got ponged!"
           chan puts stdout "Message was: $::WEBS::decoded($id)"
         }
       0 -
       1 -
       2 {

         # Final frame was received and processed.
         # So, do something with the payload data.
         chan puts stdout "XOR_read => Decoded message: $::WEBS::decoded($id)"
         chan puts stdout "Would've processed the message."


         }
       default {
           # WARNING Need an error message like a Tk window event.
           # Once get the try/catch/trap/finally code together.
           chan puts stdout {Error in XOR_Read data but bad
               op code to handle message.}
       }
    }
    # Reset the socket for next message. Any continuation frames
    # should have been read above, appended, and decoded before
    # reach this point in the code. Pretty sure tested this some-
    # where in the Channel Experiments folder.
    # Could unset this array index but it likely will be used
    # many times since there will be few and they are recycled.
    # Thus, set it to empty and delete the id.
    set ::WEBS::decoded($id) {}
#     ::WEBS::ReadId::delId $id $sock
  }
}

# ______________________________________________________

lassign [chan pipe] rchan wchan
chan configure $rchan -buffering full -blocking 0 -translation binary
chan configure $wchan -buffering full -blocking 0 -translation binary
#chan event $rchan readable [list XOR_read $rchan]

coroutine ::WEBS::coro${rchan} ::WEBS::XOR_Read $rchan
chan event $rchan readable ::WEBS::coro${rchan}

# ______________________________________________________

set response "This is a test text message."
set mKey {171 4 98 23}
binary scan $response cu* cu_resp
puts "cu_resp: $cu_resp"
puts "length cu_resp: [llength $cu_resp]"
set offset -1
foreach b $cu_resp {
  # Note that the space at the end is required or the subsequent
  # [binary format] appended to webSocket_decoded will fail.
  append temp "[expr {$b ^ [lindex $mKey [expr {[incr offset] % 4}]]}] "
}
set encoded [binary format cu* $temp]
puts "temp: $temp"
set len [string length $encoded]
# XOR encoded message
if { $len > 65535 } {
  chan puts -nonewline $wchan [binary format cu2Wucu4 {129 255} $len [list {*}$mKey]]
} elseif { $len > 125 } {
  chan puts -nonewline $wchan [binary format cu2Sucu4 {129 254} $len [list {*}$mKey]]
} elseif { $len > 0 } {
  incr len 128
  chan puts -nonewline $wchan [binary format cu6 [list 129 $len {*}$mKey]]
}
chan puts -nonewline $wchan $encoded
chan flush $wchan

after 2000 [list set forever 1]
set forever 0
vwait forever
close $rchan
close $wchan

Solution

  • Many parts of Tcl are designed around the idea of command prefixes, to which a number of arguments will get added when they are called. The bits and pieces of a scripted channel are one such place. In those cases, the implementation can be anything that accepts the arguments. TclOO is one way of making implementations (and one that has enough internal state that the "command prefix" could be just a command name) but there are others, such as ensembles or just doing the processing yourself. But Tcl just cares whether they behave right.

    The thing to focus on is that when an operation is done on the channel (e.g., chan gets then that gets mapped into a call to your implementation with the arguments as described. In particular, you get told what operation was done, to what channel, and what the parameters to the operation were. (These may be indirectly mapped from the Tcl command that triggered the call; there is a buffering and encoding management layer between, and you might have other transformations stacked in there too.)

    [EDIT] To prove that you don't need anything fancy at all, here's a simple channel that uses just a procedure (and a globally-scoped variable to be a buffer):

    proc channelImpl {command channelId args} {
        variable buffer
        switch $command {
            initialize {
                lassign $args mode
                if {$mode ne "write"} {
                    error "only support writing"
                }
                set buffer($channelId) ""
                # We will ignore watch for simplicity, but it must be there
                return {
                    initialize finalize watch write
                }
            }
            finalize {
                puts ">>$buffer($channelId)<<"
                unset buffer($channelId)
            }
            write {
                lassign $args data
                append buffer($channelId) $data
                return [string length $data]
            }
        }
    }
    
    set ch [chan create write channelImpl]
    puts $ch "abc"
    puts $ch "def ghi"
    puts -nonewline $ch "jkl"
    puts $ch "mno"
    puts "after writes"
    close $ch
    puts "after close"
    

    Output:

    after writes
    >>abc
    def ghi
    jklmno
    <<
    after close
    

    [EDIT2]: Here's versions with ensembles and TclOO for comparison. Output is identical.

    namespace eval channelImpl {
        proc initialize {channelId mode} {
            variable buffer
            if {$mode ne "write"} {
                error "only support writing"
            }
            set buffer($channelId) ""
            return {
                initialize finalize watch write
            }
        }
        proc finalize {channelId} {
            variable buffer
            puts ">>$buffer($channelId)<<"
            unset buffer($channelId)
        }
        proc watch {args} {
            # We will ignore watch for simplicity, but it must be there
        }
        proc write {channelId data} {
            variable buffer
            append buffer($channelId) $data
            return [string length $data]
        }
        namespace export *
        namespace ensemble create
    }
    
    set ch [chan create write channelImpl]
    puts $ch "abc"
    puts $ch "def ghi"
    puts -nonewline $ch "jkl"
    puts $ch "mno"
    puts "after writes"
    close $ch
    puts "after close"
    
    oo::class create Channel {
        variable buffer
        constructor {} {
            set buffer ""
        }
        method initialize {channelId mode} {
            if {$mode ne "write"} {
                error "only support writing"
            }
            return {
                initialize finalize watch write
            }
        }
        method finalize {channelId} {
            puts ">>$buffer<<"
            my destroy
        }
        method watch args {}
        method write {channelId data} {
            append buffer $data
            return [string length $data]
        }
    }
    
    set ch [chan create write [Channel new]]
    puts $ch "abc"
    puts $ch "def ghi"
    puts -nonewline $ch "jkl"
    puts $ch "mno"
    puts "after writes"
    close $ch
    puts "after close"