Posted to tcl by crshults at Thu Nov 20 17:46:51 GMT 2014view raw

  1. #I usually shuffle this stuff off into my list_tools and binary_tools modules
  2. proc convert_binary_to_bit_list {input} {
  3. binary scan $input B* bit_string
  4. split $bit_string ""
  5. }
  6.  
  7. proc invert_bit_list {bit_list} {
  8. foreach bit $bit_list {
  9. switch $bit {
  10. 0 {lappend inverted_bit_list 1}
  11. 1 {lappend inverted_bit_list 0}
  12. }
  13. }
  14. return $inverted_bit_list
  15. }
  16.  
  17. package require list_tools
  18.  
  19. proc bassign {input fields_and_lengths} {
  20. set bit_list [convert_binary_to_bit_list $input]
  21. foreach {field length} $fields_and_lengths {
  22. uplevel "scan [join [lpop bit_list $length] ""] %b $field"
  23. }
  24. return [binary format B* [join $bit_list ""]]
  25. }
  26.  
  27. #Here's the start of the actual thing
  28. package require TclOO
  29. package require sha1
  30.  
  31. oo::class create websocket_server {
  32. variable clients handler server_socket
  33.  
  34. constructor {port callback} {
  35. set clients [list]
  36. set handler $callback
  37. set server_socket [socket -server [list [self] accept_connection] $port]
  38. }
  39.  
  40. destructor {
  41. close $server_socket
  42. }
  43.  
  44. method accept_connection {client_socket address port} {
  45. lappend clients $client_socket
  46. chan configure $client_socket -blocking no -buffering none -encoding iso8859-1 -translation crlf
  47. chan event $client_socket readable [list [self] perform_handshake $client_socket]
  48. }
  49.  
  50. method perform_handshake {client_socket} {
  51. set request [split [chan read $client_socket] \n]
  52. if {[chan eof $client_socket]} {
  53. chan close $client_socket
  54. set clients [lsearch -inline -all -not -exact $clients $client_socket]
  55. } else {
  56. set key [lindex [lindex $request [lsearch $request Sec-WebSocket-Key*]] end]
  57. chan puts $client_socket "HTTP/1.1 101 Switching Protocols"
  58. chan puts $client_socket "Upgrade: websocket"
  59. chan puts $client_socket "Connection: Upgrade"
  60. chan puts $client_socket "Sec-WebSocket-Accept: [binary encode base64 [sha1::sha1 -bin ${key}258EAFA5-E914-47DA-95CA-C5AB0DC85B11]]"
  61. chan puts $client_socket ""
  62. chan event $client_socket readable [list [self] read_data $client_socket]
  63. }
  64. }
  65.  
  66. method read_data {client_socket} {
  67. set received_message [chan read $client_socket]
  68. if {[chan eof $client_socket]} {
  69. chan close $client_socket
  70. set clients [lsearch -inline -all -not -exact $clients $client_socket]
  71. }
  72. while {[string length $received_message] > 0} {
  73. set received_message [bassign $received_message {fin 1 rsv1 1 rsv2 1 rsv3 1 opcode 4 mask 1 payload_length 7}]
  74. switch $payload_length {
  75. 126 {set received_message [bassign $received_message {payload_length 16}]}
  76. 127 {set received_message [bassign $received_message {payload_length 64}]}
  77. }
  78. binary scan $received_message c1c1c1c1c$payload_length masking_key(0) masking_key(1) masking_key(2) masking_key(3) payload
  79. set received_message [string range $received_message [expr {$payload_length+4}] end]
  80. for {set i 0} {$i < $payload_length} {incr i} {
  81. append message [binary format c1 [expr {[lindex $payload $i] ^ $masking_key([expr $i % 4])}]]
  82. }
  83. $handler $message
  84. set message {}
  85. }
  86. }
  87.  
  88. method broadcast {message} {
  89. set length [string length $message]
  90. if {$length < 126} {
  91. set message \x81[binary format H* [format %02x [string length $message]]]$message
  92. } elseif {$length < 65536} {
  93. set message \x81\x7e[binary format H* [format %04x [string length $message]]]$message
  94. } else {
  95. #client will close the connection if you try to send a single message this big
  96. set message \x81\x7f[binary format H* [format %08x [string length $message]]]$message
  97. }
  98. foreach client $clients {
  99. puts -nonewline $client $message
  100. }
  101. }
  102. }
  103.  
  104. #Example usage:
  105. proc callback {message} {puts $message}
  106. websocket_server create myServer 9999 callback
  107.  
  108. #Then at the FireBug console:
  109. var sock = new WebSocket("ws://localhost:9999");
  110. sock.onmessage = function(message) {console.log(message)};
  111. sock.send("This is a message from the browser");
  112.  
  113. #And back at tkcon:
  114. myServer broadcast "Hello from the WebSocket server!"
  115.