WebSocket Simplementation

#I usually shuffle this stuff off into my list_tools and binary_tools modules
proc convert_binary_to_bit_list {input} {
    binary scan $input B* bit_string
    split $bit_string ""
}

proc invert_bit_list {bit_list} {
    foreach bit $bit_list {
        switch $bit {
            0 {lappend inverted_bit_list 1}
            1 {lappend inverted_bit_list 0}
        }
    }
    return $inverted_bit_list
}

package require list_tools

proc bassign {input fields_and_lengths} {
    set bit_list [convert_binary_to_bit_list $input]
    foreach {field length} $fields_and_lengths {
        uplevel "scan [join [lpop bit_list $length] ""] %b $field"
    }
    return [binary format B* [join $bit_list ""]]
}

#Here's the start of the actual thing
package require TclOO
package require sha1

oo::class create websocket_server {
    variable clients handler server_socket

    constructor {port callback} {
        set clients [list]
        set handler $callback
        set server_socket [socket -server [list [self] accept_connection] $port]
    }

    destructor {
        close $server_socket
    }

    method accept_connection {client_socket address port} {
        lappend clients $client_socket
        chan configure $client_socket -blocking no -buffering none -encoding iso8859-1 -translation crlf
        chan event $client_socket readable [list [self] perform_handshake $client_socket]
    }

    method perform_handshake {client_socket} {
        set request [split [chan read $client_socket] \n]
        if {[chan eof $client_socket]} {
            chan close $client_socket
            set clients [lsearch -inline -all -not -exact $clients $client_socket]
        } else {
            set key [lindex [lindex $request [lsearch $request Sec-WebSocket-Key*]] end]
            chan puts $client_socket "HTTP/1.1 101 Switching Protocols"
            chan puts $client_socket "Upgrade: websocket"
            chan puts $client_socket "Connection: Upgrade"
            chan puts $client_socket "Sec-WebSocket-Accept: [binary encode base64 [sha1::sha1 -bin ${key}258EAFA5-E914-47DA-95CA-C5AB0DC85B11]]"
            chan puts $client_socket ""
            chan event $client_socket readable [list [self] read_data $client_socket]
        }
    }

    method read_data {client_socket} {
        set received_message [chan read $client_socket]
        if {[chan eof $client_socket]} {
            chan close $client_socket
            set clients [lsearch -inline -all -not -exact $clients $client_socket]
        }
        while {[string length $received_message] > 0} {
            set received_message [bassign $received_message {fin 1 rsv1 1 rsv2 1 rsv3 1 opcode 4 mask 1 payload_length 7}]
            switch $payload_length {
                126 {set received_message [bassign $received_message {payload_length 16}]}
                127 {set received_message [bassign $received_message {payload_length 64}]}
            }
            binary scan $received_message c1c1c1c1c$payload_length masking_key(0) masking_key(1) masking_key(2) masking_key(3) payload
            set received_message [string range $received_message [expr {$payload_length+4}] end]
            for {set i 0} {$i < $payload_length} {incr i} {
                append message [binary format c1 [expr {[lindex $payload $i] ^ $masking_key([expr $i % 4])}]]
            }
            $handler $message
            set message {}
        }
    }

    method broadcast {message} {
        set length [string length $message]
        if {$length < 126} {
            set message \x81[binary format H* [format %02x [string length $message]]]$message
        } elseif {$length < 65536} {
            set message \x81\x7e[binary format H* [format %04x [string length $message]]]$message
        } else {
            #client will close the connection if you try to send a single message this big
            set message \x81\x7f[binary format H* [format %08x [string length $message]]]$message
        }
        foreach client $clients {
            puts -nonewline $client $message
        }
    }
}

#Example usage:
proc callback {message} {puts $message}
websocket_server create myServer 9999 callback

#Then at the FireBug console:
var sock = new WebSocket("ws://localhost:9999");
sock.onmessage = function(message) {console.log(message)};
sock.send("This is a message from the browser");

#And back at tkcon:
myServer broadcast "Hello from the WebSocket server!"