##################
## Module Name -- websocket
## Original Author -- Emmanuel Frecon - [email protected]
## Description:
##
## This library implements a WebSocket client library on top of the
## existing http package. The library implements the HTTP-like
## handshake and the necessary framing of messages on sending and
## reception. The library is also server-aware, i.e. implementing
## the slightly different framing when communicating from a server
## to a client. Part of the code comes (with modifications) from
## the following Wiki page: http://wiki.tcl.tk/26556
##
##################
package require Tcl 8.4
package require http 2.7; # Need keepalive!
package require logger
package require sha1
package require base64
# IMPLEMENTATION NOTES:
#
# The rough idea behind this library is to misuse the standard HTTP
# package so as to benefit from all its handshaking and the solid
# implementation of the HTTP protocol that it provides. "Misusing"
# means requiring the HTTP package to keep the socket alive, which
# giving away the opened socket to the library once all initial HTTP
# handshaking has been performed. From that point and onwards, the
# library is responsible for the framing of fragments of messages on
# the socket according to the RFC.
#
# The library almost solely uses the standard API of the HTTP package,
# thus being future-proof as much as possible as long as the HTTP
# package is kept backwards compatible. HOWEVER, it requires to
# extract the identifier of the socket towards the server from the
# state array. This extraction is not officially specified in the man
# page of the library and could therefor be subject to change in the
# future.
namespace eval ::websocket {
variable WS
if { ! [info exists WS] } {
array set WS {
loglevel "warn"
maxlength 16777216
ws_magic "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
ws_version 13
id_gene 0
-keepalive 30
-ping ""
}
variable log [::logger::init [string trimleft [namespace current] ::]]
variable libdir [file dirname [file normalize [info script]]]
${log}::setlevel $WS(loglevel)
}
}
# ::websocket::loglevel -- Set or query loglevel
#
# Set or query the log level of the library, which defaults to
# warn. The library provides much more debugging help when set
# to debug.
#
# Arguments:
# loglvl New loglevel, empty for no change
#
# Results:
# Return the (changed?) log level of the library
#
# Side Effects:
# Increasing the loglevel of the library will output an
# increased number of messages via the logger package.
proc ::websocket::loglevel { { loglvl "" } } {
variable WS
variable log
if { $loglvl != "" } {
if { [catch "${log}::setlevel $loglvl"] == 0 } {
set WS(loglevel) $loglvl
}
}
return $WS(loglevel)
}
# ::websocket::Disconnect -- Disconnect from remote end
#
# Disconnects entirely from remote end, providing an event in
# the handler associated to the socket. This event is of type
# "disconnect". Upon disconnection, the socket is closed and
# all state concerning that WebSocket is forgotten.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::Disconnect { sock } {
variable WS
set varname [namespace current]::Connection_$sock
upvar \#0 $varname Connection
if { $Connection(liveness) ne "" } {
after cancel $Connection(liveness)
}
Push $sock disconnect "Disconnected from remote end"
catch {::close $sock}
unset $varname
}
# ::websocket::close -- Close a WebSocket
#
# Close a WebSocket, while sending the remote end a close frame
# to describe the reason for the closure.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
# code Reason code, as suggested by the RFC
# reason Descriptive message, empty to rely on builtin messages.
#
# Results:
# None.
#
# Side Effects:
# Will eventually disconnect the socket and loose connection to
# the remote end.
proc ::websocket::close { sock { code 1000 } { reason "" } } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
if { $Connection(state) eq "CLOSED" } {
${log}::notice "Connection already closed"
return
}
set Connection(state) CLOSED
if { $code == "" || ![string is integer $code] } {
send $sock 8
${log}::info "Closing web socket"
Push $sock close {}
} else {
if { $reason eq "" } {
set reason [string map \
{ 1000 "Normal closure" \
1001 "Endpoint going away" \
1002 "Protocol error" \
1003 "Received incompatible data type" \
1006 "Abnormal closure" \
1007 "Received data not consistent with type" \
1008 "Policy violation" \
1009 "Received message too big" \
1010 "Missing extension" \
1011 "Unexpected condition" \
1015 "TLS handshake error" } $code]
}
set msg [binary format Su $code]
append msg [encoding convertto utf-8 $reason]
set msg [string range $msg 0 124]; # Cut answer to make sure it fits!
send $sock 8 $msg
${log}::info "Closing web socket: $code ($reason)"
Push $sock close [list $code $reason]
}
Disconnect $sock
}
# ::websocket::Push -- Push event or data to handler
#
# Every WebSocket is associated to a handler that will be
# notified upon reception of data, but also upon important
# events within the library or events resulting from control
# messages sent by the remote end. This procedure calls this
# handler, catching all errors that might occur within the
# handler. The types that the library pushes out via this
# callback are:
# text Text complete message
# binary Binary complete message
# connect Notification of successful connection to server
# disconnect Disconnection from remote end.
# close Pending closure of connection
#
# Arguments:
# sock WebSocket that was taken over or created by this library
# type Type of the event
# msg Data of the event.
# handler Use this command to push back instead of handler at WebSocket
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::Push { sock type msg { handler "" } } {
variable WS
variable log
# If we have not specified a handler, which is in most cases, pick
# up the handler from the array that contains all WS-relevant
# information.
if { $handler eq "" } {
set varname [namespace current]::Connection_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
set handler $Connection(handler)
}
# Ugly but working eval...
if { [catch {eval [concat $handler [list $sock $type $msg]]} res] } {
${log}::error "Error when executing WebSocket reception handler: $res"
}
}
# ::websocket::Ping -- Send a ping
#
# Sends a ping at regular intervals to keep the connection alive
# and prevent equipment to close it due to inactivity.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::Ping { sock } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
# Reschedule at once to get around any possible problem with ping
# sending.
Liveness $sock
# Now send a ping, which will trigger a pong from the
# (well-behaved) client.
${log}::debug "Sending ping to keep connection alive"
send $sock ping $Connection(-ping)
}
# ::websocket::Liveness -- Keep connections alive
#
# Keep connections alive (from the server side by construction),
# as suggested by the specification. This procedure arranges to
# send pings after a given period of inactivity within the
# socket. This ties to ensure that all equipment keep the
# connection open.
#
# Arguments:
# sock Existing Web socket
#
# Results:
# Return the time to next ping, negative or zero if not relevant.
#
# Side Effects:
# None.
proc ::websocket::Liveness { sock } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
upvar \#0 $varname Connection
# Keep connection alive by issuing pings.
if { $Connection(liveness) ne "" } {
after cancel $Connection(liveness)
}
set when [expr {$Connection(-keepalive)*1000}]
if { $when > 0 } {
set Connection(liveness) [after $when [namespace current]::Ping $sock]
} else {
set Connection(liveness) ""
}
return $when
}
proc ::websocket::Type { opcode } {
variable WS
variable log
array set TYPES {1 text 2 binary 8 close 9 ping 10 pong}
if { [array names TYPES $opcode] } {
set type $TYPES($opcode)
} else {
set type <opcode-$opcode>
}
return $type
}
# ::websocket::test -- Test incoming client connections for WebSocket
#
# This procedure will test if the connection from an incoming
# client is the opening of a WebSocket stream. The socket is
# not upgraded at once, instead a (temporary) context for the
# incoming connection is created. This allows server code to
# perform a number of actions, if necessary before the WebSocket
# stream connection goes live. The test is made by analysing
# the content of the headers. Additionally, the procedure
# checks that there exist a valid handler for the path
# requested.
#
# Arguments:
# srvSock Socket to WebSocket compliant HTTP server
# cliSock Socket to incoming connected client.
# path Path requested by client at server
# hdrs Dictionary list of the HTTP headers.
# qry Dictionary list of the HTTP query (if applicable).
#
# Results:
# 1 if this is an incoming WebSocket upgrade request for a
# recognised path, 0 otherwise.
#
# Side Effects:
# None.
proc ::websocket::test { srvSock cliSock path { hdrs {} } { qry {} } } {
variable WS
variable log
if { [llength $hdrs] <= 0 } {
return 0
}
set varname [namespace current]::Server_$srvSock
if { ! [info exists $varname] } {
${log}::warn "$srvSock is not a WebSocket server anymore"
return -code error "$srvSock is not a WebSocket"
}
upvar \#0 $varname Server
# Detect presence of connection and upgrade HTTP headers, together
# with their proper values.
set upgrading 0
set websocket 0
foreach {k v} $hdrs {
if { [string equal -nocase $k "connection"] && \
[string equal -nocase $v "upgrade"] } {
set upgrading 1
}
if { [string equal -nocase $k "upgrade"] && \
[string equal -nocase $v "websocket"] } {
set websocket 1
}
}
# Fail early when not upgrading to a websocket.
if { !$upgrading || !$websocket } {
return 0
}
# If headers point towards a possible websocket...
set key ""
set protos {}
foreach {k v} $hdrs {
if { [string equal -nocase $k "sec-websocket-key"] } {
set key $v
}
if { [string equal -nocase $k "sec-websocket-protocol"] } {
set protos [split $v ","]
}
}
# We thought we had a websocket, but no security handshake is
# provided by client. Discard this connection!
if { $key eq "" } {
return 0
}
# Create a context for the incoming client
set varname [namespace current]::Client_${srvSock}_${cliSock}
upvar \#0 $varname Client
set Client(server) $srvSock
set Client(sock) $cliSock
set Client(key) $key
set Client(accept) ""
set Client(path) $path
set Client(query) $qry
if { $key ne "" } {
set sec ${key}$WS(ws_magic)
set Client(accept) [::base64::encode [sha1::sha1 -bin $sec]]
}
set Client(protos) $protos
set Client(protocol) ""
set Client(live) ""
# Search amongst existing WS handlers for one that responds to
# that URL and implement one of the protocols.
foreach { ptn cb proto } $Server(live) {
set idx [lsearch -glob $protos $proto]
if { [string match -nocase $ptn $path] \
&& ( $protos == "" || $idx >= 0 ) } {
# Found it! Remember it in the client context.
if { $idx >= 0 } {
set Client(protocol) [lindex $protos $idx]
}
set Client(live) $cb
break
}
}
if { $Client(live) eq "" } {
${log}::warn "Cannot find any handler for $path"
unset $varname; # Get rid of the client context
return 0
}
# Return the context for the incoming client.
return 1
}
# ::websocket::upgrade -- Upgrade socket to WebSocket in servers
#
# Upgrade a socket that had been deemed to be an incoming
# WebSocket connection request (see ::websocket::test) to a true
# WebSocket. This procedure will send the necessary connection
# handshake to the client, arrange for the relevant callbacks to
# be made during the life of the WebSocket and mediate of the
# incoming request via a special "request" message.
#
# Arguments:
# sock Socket to client.
#
# Results:
# None.
#
# Side Effects:
# The socket is kept open and becomes a WebSocket, pushing out
# callbacks as explained in ::websocket::takeover and accepting
# messages as explained in ::websocket::send.
proc ::websocket::upgrade { sock } {
variable WS
variable log
set clients [info vars [namespace current]::Client_*_${sock}]
if { [llength $clients] == 0 } {
${log}::warn "$sock does not point to a client WebSocket"
return -code error "$sock is not a WebSocket client"
}
set c [lindex $clients 0]; # Should only be one really...
upvar \#0 $c Client
# Write client response header, this is the last time we speak
# "http"...
puts $sock "HTTP/1.1 101 Switching Protocols"
puts $sock "Upgrade: websocket"
puts $sock "Connection: Upgrade"
puts $sock "Sec-WebSocket-Accept: $Client(accept)"
if { $Client(protocol) != "" } {
puts $sock "Sec-WebSocket-Protocol: $Client(protocol)"
}
puts $sock ""
flush $sock
# Make the socket a server websocket
takeover $sock $Client(live) 1
# Tell the websocket handler that we have a new incoming
# request. We mediate this through the "message" part, which in
# this case is composed of a list containing the URL and the query
# (itself as a list). Implementation is rather ugly since we call
# the hidden method in the websocket code!
Push $sock request [list $Client(path) $Client(query)]
# Get rid of the temporary client state
unset $c
}
# ::websocket::live -- Register WebSocket callbacks for servers
#
# This procedure registers callbacks that will be performed on a
# WebSocket compliant server whenever a client connects to a
# matching path and protocol.
#
# Arguments:
# sock Socket to known WebSocket compliant HTTP server.
# path glob-style path to match in client.
# cb command to callback (same args as ::websocket::takeover)
# proto Application protocol
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::live { sock path cb { proto "*" } } {
variable WS
variable log
set varname [namespace current]::Server_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket server anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Server
lappend Server(live) $path $cb $proto
}
# ::webserver::server -- Declare WebSocket server
#
# This procedure registers the (accept) socket passed as an
# argument as the identifier for an HTTP server that is capable
# of doing WebSocket.
#
# Arguments:
# sock Socket on which the server accepts incoming connections.
#
# Results:
# Return the socket.
#
# Side Effects:
# None.
proc ::websocket::server { sock } {
variable WS
variable log
set varname [namespace current]::Server_$sock
upvar \#0 $varname Server
set Server(sock) $sock
set Server(live) {}
return $sock
}
# ::websocket::send -- Send message or fragment to remote end.
#
# Sends a fragment or a control message to the remote end of the
# WebSocket. The type of the message is passed as a parameter
# and can either be an integer according to the specification or
# one of the following strings: text, binary, ping. When
# fragmenting, it is not allowed to change the type of the
# message between fragments.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
# type Type of the message (see above)
# msg Data of the fragment.
# final True if final fragment
#
# Results:
# Returns the number of bytes sent, or -1 on error. Serious
# errors will trigger errors that must be catched.
#
# Side Effects:
# None.
proc ::websocket::send { sock type {msg ""} {final 1}} {
variable WS
variable log
set varname [namespace current]::Connection_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
# Refuse to send if not connected
if { $Connection(state) ne "CONNECTED" } {
${log}::warn "Cannot send along WS $sock, not connected"
return -1
}
# Determine opcode from type, i.e. text, binary or ping. Accept
# integer opcodes for internal use or for future extensions of the
# protocol.
set opcode -1;
if { [string is integer $type] } {
set opcode $type
} else {
switch -glob -nocase -- $type {
t* {
# text
set opcode 1
}
b* {
# binary
set opcode 2
}
p* {
# ping
set opcode 9
}
}
}
if { $opcode < 0 } {
return -code error \
"Unrecognised type, should be one of text, binary, ping or\
a protocol valid integer"
}
# Refuse to continue if different from last type of message.
if { $Connection(write:opcode) > 0 } {
if { $opcode != $Connection(write:opcode) } {
return -code error \
"Cannot change type of message under continuation!"
}
set opcode 0; # Continuation
} else {
set Connection(write:opcode) $opcode
}
# Encode text
set type [Type $Connection(write:opcode)]
if { $Connection(write:opcode) == 1 } {
set msg [encoding convertto utf-8 $msg]
}
# Reset continuation state once sending last fragment of message.
if { $final } {
set Connection(write:opcode) -1
}
# Start assembling the header.
set header [binary format c [expr {!!$final << 7 | $opcode}]]
# Append the length of the message to the header. Small lengths
# fit directly, larger ones use the markers 126 or 127. We need
# also to take into account the direction of the socket, since
# clients shall randomly mask data.
set mlen [string length $msg]
if { $mlen < 126 } {
set plen [string length $msg]
} elseif { $mlen < 65536 } {
set plen 126
} else {
set plen 127
}
# Set mask bit and push regular length into header.
if { [string is true $Connection(server)] } {
append header [binary format c $plen]
set dst "client"
} else {
append header [binary format c [expr {1 << 7 | $plen}]]
set dst "server"
}
# Appends "longer" length when the message is longer than 125 bytes
if { $mlen > 125 } {
if { $mlen < 65536 } {
append header [binary format Su $mlen]
} else {
append header [binary format Wu $mlen]
}
}
# Add the masking key and perform client masking whenever relevant
if { [string is false $Connection(server)] } {
set mask [expr {int(rand()*4294967296)}]
append header [binary format Iu $mask]
set msg [Mask $mask $msg]
}
# Send the (masked) frame
if { [catch {
puts -nonewline $sock $header$msg;
flush $sock;} err]} {
${log}::error "Could not send to remote end, closed socket? ($err)"
close $sock 1001
return -1
}
# Keep socket alive at all times.
Liveness $sock
if { [string is true $final] } {
${log}::debug "Sent $mlen bytes long $type final fragment to $dst"
} else {
${log}::debug "Sent $mlen bytes long $type fragment to $dst"
}
return [string length $header$msg]
}
# ::websocket::Mask -- Mask data according to RFC
#
# XOR mask data with the provided mask as described in the RFC.
#
# Arguments:
# mask Mask to use to mask the data
# dta Bytes to mask
#
# Results:
# Return the mask bytes, i.e. as many bytes as the data that was
# given to this procedure, though XOR masked.
#
# Side Effects:
# None.
proc ::websocket::Mask { mask dta } {
variable WS
variable log
# Format data as a list of 32-bit integer
# words and list of 8-bit integer byte leftovers. Then unmask
# data, recombine the words and bytes, and return
binary scan $dta I*c* words bytes
set masked_words {}
set masked_bytes {}
for {set i 0} {$i < [llength $words]} {incr i} {
lappend masked_words [expr {[lindex $words $i] ^ $mask}]
}
for {set i 0} {$i < [llength $bytes]} {incr i} {
lappend masked_bytes [expr {[lindex $bytes $i] ^
($mask >> (24 - 8 * $i))}]
}
return [binary format I*c* $masked_words $masked_bytes]
}
# ::websocket::Receiver -- Receive (framed) data from WebSocket
#
# Received framed data from a WebSocket, recontruct all
# fragments to a complete message whenever the final fragment is
# received and calls the handler associated to the WebSocket
# with the content of the message once it has been
# reconstructed. Interleaved control frames are also passed
# further to the handler. This procedure also automatically
# responds to ping by pongs.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
#
# Results:
# None.
#
# Side Effects:
# Read a frame from the socket, possibly blocking while reading.
proc ::websocket::Receiver { sock } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
# Keep connection alive by issuing pings.
Liveness $sock
# Get basic header. Abort if reserved bits are set, unexpected
# continuation frame, fragmented or oversized control frame, or
# the opcode is unrecognised.
if { [catch {read $sock 2} dta] || [string length $dta] != 2 } {
if {[chan eof $sock]} {
set dta "Socket closed."
}
${log}::error "Cannot read header from socket: $dta"
close $sock 1001
return
}
binary scan $dta Su header
set opcode [expr {$header >> 8 & 0xf}]
set mask [expr {$header >> 7 & 0x1}]
set len [expr {$header & 0x7f}]
set reserved [expr {$header >> 12 & 0x7}]
if { $reserved \
|| ($opcode == 0 && $Connection(read:mode) eq "") \
|| ($opcode > 7 && (!($header & 0x8000) || $len > 125)) \
|| [lsearch {0 1 2 8 9 10} $opcode] < 0 } {
# Send close frame, reason 1002: protocol error
close $sock 1002
return
}
# Determine the opcode for this frame, i.e. handle continuation of
# frames. Control frames must not be split/continued (RFC6455 5.5).
# No multiplexing here!
if { $Connection(read:mode) eq "" } {
set Connection(read:mode) $opcode
} elseif { $opcode == 0 } {
set opcode $Connection(read:mode)
}
# Get the extended length, if present
if { $len == 126 } {
if { [catch {read $sock 2} dta] || [string length $dta] != 2 } {
${log}::error "Cannot read length from socket: $dta"
close $sock 1001
return
}
binary scan $dta Su len
} elseif { $len == 127 } {
if { [catch {read $sock 8} dta] || [string length $dta] != 8 } {
${log}::error "Cannot read length from socket: $dta"
close $sock 1001
return
}
binary scan $dta Wu len
}
# Control frames use a separate buffer, since they can be
# interleaved in fragmented messages.
if { $opcode > 7 } {
# Control frames should be shorter than 125 bytes
if { $len > 125 } {
close $sock 1009
return
}
set oldmsg $Connection(read:msg)
set Connection(read:msg) ""
} else {
# Limit the maximum message length
if { [string length $Connection(read:msg)] + $len > $WS(maxlength) } {
# Send close frame, reason 1009: frame too big
close $sock 1009 "Limit $WS(maxlength) exceeded"
return
}
}
if { $mask } {
# Get mask and data. Format data as a list of 32-bit integer
# words and list of 8-bit integer byte leftovers. Then unmask
# data, recombine the words and bytes, and append to the buffer.
if { [catch {read $sock 4} dta] || [string length $dta] != 4 } {
${log}::error "Cannot read mask from socket: $dta"
close $sock 1001
return
}
binary scan $dta Iu mask
if { [catch {read $sock $len} bytes] } {
${log}::error "Cannot read fragment content from socket: $bytes"
close $sock 1001
return
}
append Connection(read:msg) [Mask $mask $bytes]
} else {
if { [catch {read $sock $len} bytes] \
|| [string length $bytes] != $len } {
${log}::error "Cannot read fragment content from socket: $bytes"
close $sock 1001
return
}
append Connection(read:msg) $bytes
}
if { [string is true $Connection(server)] } {
set dst "client"
} else {
set dst "server"
}
set type [Type $Connection(read:mode)]
# If the FIN bit is set, process the frame.
if { $header & 0x8000 } {
${log}::debug "Received $len long $type final fragment from $dst"
switch $opcode {
1 {
# Text: decode and notify handler
Push $sock text \
[encoding convertfrom utf-8 $Connection(read:msg)]
}
2 {
# Binary: notify handler, no decoding
Push $sock binary $Connection(read:msg)
}
8 {
# Close: decode, notify handler and close frame.
if { [string length $Connection(read:msg)] >= 2 } {
binary scan [string range $Connection(read:msg) 0 1] Su \
reason
set msg [encoding convertfrom utf-8 \
[string range $Connection(read:msg) 2 end]]
close $sock $reason $msg
} else {
close $sock
}
return
}
9 {
# Ping: send pong back and notify handler since this
# might contain some data.
send $sock 10 $Connection(read:msg)
Push $sock ping $Connection(read:msg)
}
}
# Prepare for next frame.
if { $opcode < 8 } {
# Reinitialise
set Connection(read:msg) ""
set Connection(read:mode) ""
} else {
set Connection(read:msg) $oldmsg
if {$Connection(read:mode) eq $opcode} {
# non-interjected control frame, clear mode
set Connection(read:mode) ""
}
}
} else {
${log}::debug "Received $len long $type fragment from $dst"
}
}
# ::websocket::New -- Create new websocket connection context
#
# Create a blank new websocket connection context array, the
# connection is placed in the state "CONNECTING" meaning that it
# is not ready for action yet.
#
# Arguments:
# sock Socket to remote end
# handler Handler callback
# server Is this a server or a client socket
#
# Results:
# Return the internal name of the array storing connection
# details.
#
# Side Effects:
# This procedure will reinitialise the connection information
# for the socket if it was already known. This is on purpose
# and by design, but worth noting.
proc ::websocket::New { sock handler { server 0 } } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
upvar \#0 $varname Connection
set Connection(sock) $sock
set Connection(handler) $handler
set Connection(server) $server
set Connection(peername) 0.0.0.0
set Connection(sockname) 127.0.0.1
set Connection(read:mode) ""
set Connection(read:msg) ""
set Connection(write:opcode) -1
set Connection(state) CONNECTING
set Connection(liveness) ""
# Arrange for keepalive to be zero, i.e. no pings, when we are
# within a client. When in servers, take the default from the
# library. In any case, this can be configured, which means that
# even clients can start sending pings when nothing has happened
# on the line if necessary.
if { [string is true $server] } {
set Connection(-keepalive) $WS(-keepalive)
} else {
set Connection(-keepalive) 0
}
set Connection(-ping) $WS(-ping)
return $varname
}
# ::websocket::takeover -- Take over an existing socket.
#
# Take over an existing opened socket to implement sending and
# receiving WebSocket framing on top of the socket. The
# procedure takes a handler, i.e. a command that will be called
# whenever messages, control messages or other important
# internal events are received or occur.
#
# Arguments:
# sock Existing opened socket.
# handler Command to call on events and incoming messages.
# server Is this a socket within a server, i.e. towards a client.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::takeover { sock handler { server 0 } } {
variable WS
variable log
# Create (or update) connection
set varname [New $sock $handler $server]
upvar \#0 $varname Connection
set Connection(state) CONNECTED
# Gather information about local and remote peer.
if { [catch {fconfigure $sock -peername} sockinfo] == 0 } {
set Connection(peername) [lindex $sockinfo 1]
if { $Connection(peername) eq "" } {
set Connection(peername) [lindex $sockinfo 0]
}
}
if { [catch {fconfigure $sock -sockname} sockinfo] == 0 } {
set Connection(sockname) [lindex $sockinfo 1]
if { $Connection(sockname) eq "" } {
set Connection(sockname) [lindex $sockinfo 0]
}
}
# Listen to incoming traffic on socket and make sure we ping if
# necessary.
fconfigure $sock -translation binary -blocking on
fileevent $sock readable [list [namespace current]::Receiver $sock]
Liveness $sock
${log}::debug "$sock has been registered as a\
[expr $server?\"server\":\"client\"] WebSocket"
}
# ::websocket::Connected -- Handshake and framing initialisation
#
# Performs the security handshake once connection to a remote
# WebSocket server has been established and handshake properly.
# On success, start listening to framed data on the socket, and
# mediate the callers about the connection and the application
# protocol that was chosen by the server.
#
# Arguments:
# opener Temporary HTTP connection opening object.
# sock Socket connection to server, empty to pick from HTTP state array
# token HTTP state array.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::Connected { opener sock token } {
variable WS
variable log
upvar \#0 $opener OPEN
# Dig into the internals of the HTTP library for the socket if
# none present as part of the arguments (ugly...)
if { $sock eq "" } {
set sock [HTTPSocket $token]
if { $sock eq "" } {
${log}::warn "Cannot extract sock from HTTP token $token, aborting"
return 0
}
}
if { [::http::ncode $token] == 101 } {
array set HDR [::http::meta $token]
# Extact security handshake, check against what was expected
# and abort in case of mismatch.
if { [array names HDR Sec-WebSocket-Accept] ne "" } {
# Compute security handshake
set sec $OPEN(nonce)$WS(ws_magic)
set accept [base64::encode [sha1::sha1 -bin $sec]]
if { $accept ne $HDR(Sec-WebSocket-Accept) } {
${log}::error "Security handshake failed"
::http::reset $token error
unset $opener
Disconnect $sock
return 0
}
}
# Extract application protocol information to pass further to
# handler.
set proto ""
if { [array names HDR Sec-WebSocket-Protocol] ne "" } {
set proto $HDR(Sec-WebSocket-Protocol)
}
# Remove the socket from the socketmap inside the http
# library. THIS IS UGLY, but the only way to make sure we
# really can take over the socket and make sure the library
# will open A NEW socket, even towards the same host, at a
# later time.
if { [info vars ::http::socketmap] ne "" } {
foreach k [array names ::http::socketmap] {
if { $::http::socketmap($k) eq $sock } {
${log}::debug "Removed socket $sock from internal state\
of http library"
unset ::http::socketmap($k)
}
}
} else {
${log}::warn "Could not remove socket $sock from socket map, future\
connections to same host and port are likely not to\
work"
}
# Takeover the socket to create a connection and mediate about
# connection via the handler.
takeover $sock $OPEN(handler)
Push $sock connect $proto; # Tell the handler which
# protocol was chosen.
} else {
Push \
"" \
error \
"Protocol error during WebSocket connection with $OPEN(url)" \
$OPEN(handler)
}
::http::cleanup $token
unset $opener; # Always unset the temporary connection opening
# array
}
# ::websocket::Finished -- Pass further on HTTP connection finalisation
#
# Pass further to Connected whenever the HTTP operation has
# been finished as implemented by the HTTP package.
#
# Arguments:
# opener Temporary HTTP connection opening object.
# sock Socket connection to server, empty to pick from HTTP state array
# token HTTP state array.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::Finished { opener token } {
Connected $opener "" $token
}
# ::websocket::Timeout -- Timeout an HTTP connection
#
# Reimplementation of the timeout facility from the HTTP package
# to be able to cleanup internal state properly and mediate to
# the handler.
#
# Arguments:
# opener Temporary HTTP connection opening object.
#
# Results:
# None.
#
# Side Effects:
# Reset the HTTP connection, which will (probably) close the
# socket.
proc ::websocket::Timeout { opener } {
variable WS
variable log
if { [info exists $opener] } {
upvar \#0 $opener OPEN
::http::reset $OPEN(token) "timeout"
set sock [HTTPSocket $OPEN(token)]
Push $sock timeout \
"Timeout when connecting to $OPEN(url)" $OPEN(handler)
::http::cleanup $OPEN(token)
unset $opener
# Destroy connection state, which will also attempt to close
# the socket.
if { $sock ne "" } {
Disconnect $sock
}
}
}
# ::websocket::HTTPSocket -- Get socket from HTTP token
#
# Extract the socket used for a given (existing) HTTP
# connection. This uses the undocumented index called "sock" in
# the HTTP state array.
#
# Arguments:
# token HTTP token, as returned by http::geturl
#
# Results:
# The socket to the remote server, or an empty string on errors.
#
# Side Effects:
# None.
proc ::websocket::HTTPSocket { token } {
variable log
upvar \#0 $token htstate
if { [array names htstate sock] eq "sock" } {
return $htstate(sock)
} else {
${log}::error "No socket associated to HTTP token $token!"
return ""
}
}
# ::websocket::open -- Open connection to remote WebSocket server
#
# Open a WebSocket connection to a remote server. This
# procedure takes a number of options, which mostly are the
# options that are supported by the http::geturl procedure.
# However, there are a few differences described below:
# -headers Is supported, but additional headers will be added internally
# -validate Is not supported, it has no point.
# -handler Is used internally, so cannot be specified.
# -command Is used internally, so cannot be specified.
# -protocol Contains a list of app. protocols to handshake with server
#
# Arguments:
# url WebSocket URL, i.e. led by ws: or wss:
# handler Command to callback on data reception or event occurence
# args List of dashled options with their values, as explained above.
#
# Results:
# Return the socket for use with the rest of the WebSocket
# library, or an empty string on errors.
#
# Side Effects:
# None.
proc ::websocket::open { url handler args } {
variable WS
variable log
# Fool the http library by replacing the ws: (websocket) scheme
# with the http, so we can use the http library to handle all the
# initial handshake.
set hturl [string map -nocase {ws: http: wss: https:} $url]
# Start creating a command to call the http library.
set cmd [list ::http::geturl $hturl]
# Control the geturl options that we can blindly pass to the
# http::geturl call. We basically remove -validate, which has no
# point and stop -handler which we will be using internally. We
# restrain the use of -timeout, implementing the timeout ourselves
# to avoid the library to close the socket to the server. We also
# intercept the headers since we will be adding WebSocket protocol
# information as part of the headers.
set protos {}
set timeout -1
array set HDR {}
foreach { k v } $args {
set allowed 0
foreach opt {bi* bl* ch* he* k* m* prog* prot* qu* s* ti* ty*} {
if { [string match -nocase $opt [string trimleft $k -]] } {
set allowed 1
}
}
if { ! $allowed } {
return -code error "$k is not a recognised option"
}
switch -nocase -glob -- [string trimleft $k -] {
he* {
# Catch the headers, since we will be adding a few
# ones by hand.
array set HDR $v
}
prot* {
# New option -protocol to support the list of
# application protocols that the client accepts.
# -protocol should be a list.
set protos $v
}
ti* {
# We implement the timeout ourselves to be able to
# properly cleanup.
if { [string is integer $v] && $v > 0 } {
set timeout $v
}
}
default {
# Any other allowed option will simply be passed
# further to the http::geturl call, to benefit from
# all its facilities.
lappend cmd $k $v
}
}
}
# Create an HTTP connection object that will contain all necessary
# internal data until the connection has been a success or until
# it failed.
set varname [namespace current]::opener_[incr WS(id_gene)]
upvar \#0 $varname OPEN
set OPEN(url) $url
set OPEN(handler) $handler
set OPEN(nonce) ""
# Construct the WebSocket part of the header according to RFC6455.
# The NONCE should be randomly chosen for each new connection
# established
set HDR(Connection) "Upgrade"
set HDR(Upgrade) "websocket"
for { set i 0 } { $i < 4 } { incr i } {
append OPEN(nonce) [binary format Iu [expr {int(rand()*4294967296)}]]
}
set OPEN(nonce) [::base64::encode $OPEN(nonce)]
set HDR(Sec-WebSocket-Key) $OPEN(nonce)
set HDR(Sec-WebSocket-Protocol) [join $protos ", "]
set HDR(Sec-WebSocket-Version) $WS(ws_version)
lappend cmd -headers [array get HDR]
# Add our own handler to intercept the socket once connection has
# been opened and established properly and make sure we keep alive
# the socket so we can continue using it. In practice, what gets
# called is the command that is specified by -command, even though
# we would like to intercept this earlier on. This has to do with
# the internals of the HTTP package.
lappend cmd \
-handler [list [namespace current]::Connected $varname] \
-command [list [namespace current]::Finished $varname] \
-keepalive 1
# Now open the connection to the remote server using the HTTP
# package...
set sock ""
if { [catch {eval $cmd} token] } {
${log}::error "Error while opening WebSocket connection to $url: $token"
} else {
set sock [HTTPSocket $token]
if { $sock ne "" } {
set varname [New $sock $handler]
if { $timeout > 0 } {
set OPEN(timeout) \
[after $timeout [namespace current]::Timeout $varname]
}
} else {
${log}::warn "Cannot extract socket from HTTP token, failure"
# Call the timeout to get rid of internal states
Timeout $varname
}
}
return $sock
}
# ::websocket::conninfo -- Connection information
#
# Provide callers with some introspection facilities in order to
# get some semi-internal data about an existing websocket. It
# returns the following pieces of information:
# peername - name or IP of remote end
# (sock)name - name or IP of local end
# closed - 1 if closed, 0 otherwise
# client - 1 if client websocket
# server - 1 if server websocket
# type - the string "server" or "client", depending on the type.
# handler - callback registered from websocket.
# state - current state of websocket, one of CONNECTING, CONNECTED or
# CLOSED.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
# what What piece of information to get, see above for details.
#
# Results:
# Return the value of the information or an empty string.
#
# Side Effects:
# None.
proc ::websocket::conninfo { sock what } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
if { ! [::info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
switch -glob -nocase -- $what {
"peer*" {
return $Connection(peername)
}
"sockname" -
"name" {
return $Connection(sockname)
}
"close*" {
return [expr {$Connection(state) eq "CLOSED"}]
}
"client" {
return [string is false $Connection(server)]
}
"server" {
return [string is true $Connection(server)]
}
"type" {
return [expr {[string is true $Connection(server)]?\
"server":"client"}]
}
"handler" {
return $Connection(handler)
}
"state" {
return $Connection(state)
}
default {
return -code error "$what is not a known information piece for\
a websocket"
}
}
return ""; # Never reached
}
# ::websocket::find -- Find an existing websocket
#
# Look among existing websockets for the ones that match the
# hostname and port number filters passed as parameters. This
# lookup takes the remote end into account.
#
# Arguments:
# host hostname filter, will also be tried against IP.
# port port filter
#
# Results:
# List of matching existing websockets.
#
# Side Effects:
# None.
proc ::websocket::find { { host * } { port * } } {
variable WS
variable log
set socks [list]
foreach varname [::info vars [namespace current]::Connection_*] {
upvar \#0 $varname Connection
foreach {ip hst prt} $Connection(peername) break
if { ([string match $host $ip] || [string match $host $hst]) \
&& [string match $port $prt] } {
lappend socks $Connection(sock)
}
}
return $socks
}
# ::websocket::configure -- Configure an existing websocket.
#
# Takes a number of dash-led options to configure the behaviour
# of an existing websocket. The recognised options are:
# -keepalive The frequency of the keepalive pings.
# -ping The text sent during pings.
#
# Arguments:
# sock WebSocket that was taken over or created by this library
# args Dash-led options and their (new) value.
#
# Results:
# None.
#
# Side Effects:
# None.
proc ::websocket::configure { sock args } {
variable WS
variable log
set varname [namespace current]::Connection_$sock
if { ! [info exists $varname] } {
${log}::warn "$sock is not a WebSocket connection anymore"
return -code error "$sock is not a WebSocket"
}
upvar \#0 $varname Connection
foreach { k v } $args {
set allowed 0
foreach opt {k* p*} {
if { [string match -nocase $opt [string trimleft $k -]] } {
set allowed 1
}
}
if { ! $allowed } {
return -code error "$k is not a recognised option"
}
switch -nocase -glob -- [string trimleft $k -] {
k* {
# Change keepalive
set Connection(-keepalive) $v
Liveness $sock; # Change at once.
}
p* {
# Change ping, i.e. text used during the automated pings.
set Connection(-ping) $v
}
}
}
}
package provide websocket 1.3;
