diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/websocket | |
parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/websocket')
-rw-r--r-- | tcllib/modules/websocket/ChangeLog | 31 | ||||
-rw-r--r-- | tcllib/modules/websocket/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | tcllib/modules/websocket/websocket.man | 385 | ||||
-rw-r--r-- | tcllib/modules/websocket/websocket.tcl | 1754 |
4 files changed, 2181 insertions, 0 deletions
diff --git a/tcllib/modules/websocket/ChangeLog b/tcllib/modules/websocket/ChangeLog new file mode 100644 index 0000000..deb2625 --- /dev/null +++ b/tcllib/modules/websocket/ChangeLog @@ -0,0 +1,31 @@ +2013-12-17 Andreas Kupries <andreask@activestate.com> + + * websocket.man: Added missing reference to the package itself. + +2015-01-07 Emmanuel Frecon <efrecon@gmail.com> + + * pkgIndex.tcl: Bumped up version number to reflect slight API changes. + * websocket.tcl: Merging in 24 patches from Adrián Medraño Calvo. + + All errors have the first word in the error code list set to + WEBSOCKET, for easier use with try...catch. + + Add a 'connect' pseudo message type, analogous to + 'disconnect', invoked whenever a socket converts into a WebSocket. + + Push connection error to socket + + Pass HTTP token to Timeout handler + + Don't overwrite OPEN with Connection context + + Properly reset socket after informing the handler + + Cancel the timeout on successful connection + + Substitute only the URI schema + + Don't clobber Connection and Upgrade headers + + Improved compliance with RFC and Browsers + + Notify handler on receiving pong frames + + Expose key construction: This is useful for servers that wish + to implement the handshake handling themselves, for example to be + able to use their own dispatching mechanism. + + Factor out handshake validation: Allows users of the websocket + library to be able to use the websocket core without having to use + the ::websocket::live, ::websocket::test and ::websocket::upgrade + functionality. This happens, for example, when the application + already has already accepted and parsed the request. In addition, + the checks are now more strict for keys and values, and more lax + with regards to case and extra tokens in header fields. diff --git a/tcllib/modules/websocket/pkgIndex.tcl b/tcllib/modules/websocket/pkgIndex.tcl new file mode 100644 index 0000000..fbd064e --- /dev/null +++ b/tcllib/modules/websocket/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded websocket 1.4 [list source [file join $dir websocket.tcl]] diff --git a/tcllib/modules/websocket/websocket.man b/tcllib/modules/websocket/websocket.man new file mode 100644 index 0000000..6c708dc --- /dev/null +++ b/tcllib/modules/websocket/websocket.man @@ -0,0 +1,385 @@ +[comment {-*- tcl -*- doctools manpage}] +[vset WEBSOCKET_VERSION 1.3.1] +[manpage_begin websocket n [vset WEBSOCKET_VERSION]] +[see_also http] +[keywords http] +[keywords internet] +[keywords net] +[keywords {rfc 6455}] +[moddesc {websocket client and server}] +[titledesc {Tcl implementation of the websocket protocol}] +[category Networking] +[require Tcl 8.4] +[require http 2.7] +[require logger] +[require sha1] +[require base64] +[require websocket [opt [vset WEBSOCKET_VERSION]]] +[description] + +[para] + +NOTE: THIS DOCUMENTATION IS WORK IN PROGRESS... + +[para] + +The websocket library is a pure Tcl implementation of the WebSocket +specification covering the needs of both clients and servers. +Websockets provide a way to upgrade a regular HTTP connection into a +long-lived and continuous binary or text communication between the +client and the server. The library offers a high-level interface to +receive and send data as specified in RFC 6455 (v. 13 of the +protocol), relieving callers from all necessary protocol framing and +reassembly. It implements the ping facility specified by the +standard, together with levers to control it. Pings are server-driven +and ensure the liveness of the connection across home (NAT) networks. +The library has a number of introspection facilities to inquire about +the current state of the connection, but also to receive notifications +of incoming pings, if necessary. Finally, the library contains a +number of helper procedures to facilitate the upgrading handshaking in +existing web servers. + +[para] + +Central to the library is the procedure [cmd websocket::takeover] that +will take over a regular socket and treat it as a WebSocket, thus +performing all necessary protocol framing, packetisation and +reassembly in servers and clients. The procedure also takes a +handler, a command that will be called back each time a (possibly +reassembled) packet from the remote end is ready for delivery at the +original caller. While exported by the package, the command +[cmd websocket::takeover] is seldom called in applications, since the +package provides other commands that are specifically tuned for the +needs of clients and servers. + +[para] + +Typically, clients will open a connection to a remote server by +providing a WebSocket URL ([term ws:] or [term wss:] schemes) and the +handler described above to the command [cmd websocket::open]. The +opening procedure is a wrapper around the latest http::geturl +implementations: it arranges to keep the socket created within the +http library opened for reuse, but confiscates it from its (internal) +map of known sockets for its own use. + +[para] + +Servers will start by registering themselves through the command +[cmd ::websocket::server] and a number of handlers for paths using the +command [cmd ::websocket::live]. Then for each incoming client +connection, they should test the incoming request to detect if it is +an upgrade request using [cmd ::websocket::test] and perform the final +handshake to place the socket connection under the control of the +websocket library and its central procedure using [cmd ::websocket::upgrade]. + +[para] + +Apart from these main commands, the package provides a number of +commands for introspection and basic operations on the websockets that +it has under its control. As WebSockets connections are long-lived, +most remaining communication with the library will be by way of +callbacks, i.e. commands that are triggered whenever important events +within the library have occur, but mostly whenever data has been +received on a WebSocket. + +[section Callbacks] + +A number of commands of the library take a handler handler command as +an argument, a command which will be called back upon reception of +data, but also upon important events within the library or events +resulting from control messages sent by the remote end. For each +callback being performed, the following arguments will be appended: + +[list_begin definitions] + +[def [arg "sock"]] + +The identifier of the WebSocket, as returned for example by +[cmd ::websocket::open] + +[def [arg "type"]] + +A textual type describing the event or message content, can be one of +the following +[list_begin definitions] +[def [const "text"]] Complete text message +[def [const "binary"]] Complete binary message +[def [const "ping"]] Incoming ping message +[def [const "connect"]] Notification of successful connection to server +[def [const "disconnect"]] Disconnection from remote end +[def [const "close"]] Pending closure of connection +[list_end] + +[def [arg "msg"]] + +Will contain the data of the message, whenever this is relevant, +i.e. when the [arg "type"] is [const "text"], [const "binary"] or +[const "ping"] and whenever there is data available. + +[list_end] + +[section API] + +[list_begin definitions] + +[call [cmd ::websocket::open] [arg url] [arg handler] [opt [arg options]]] + +This command is used in clients to open a WebSocket to a remote +websocket-enabled HTTP server. The URL provided as an argument in +[arg url] should start with ws: or wss:, which are the WebSockets +counterpart of http: and https:. The [arg handler] is a command that +will be called back on data reception or whenever important events +occur during the life of the websocket. + +[cmd ::websocket::open] will return a socket which serves as both the +identifier of the websocket and of the physical low-level socket to +the server. This socket can be used in a number of other commands for +introspection or for controlling the behaviour of the library. + +Being essentially a wrapper around the [cmd ::http::geturl] command, +this command provides mostly the same set of dash-led options than +[cmd ::http::geturl]. Documented below are the options that differ +from [cmd ::http::geturl] and which are specific to the WebSocket +library. + +[list_begin definitions] + +[def "-headers"] + +This option is supported, knowing that a number of headers will be +automatically added internally in the library in order to be able to +handshake the upgrading of the socket from a regular HTTP socket to a +WebSocket with the server. + +[def "-validate"] + +This option is not supported as it has no real point for WebSockets. + +[def "-handler"] + +This option is used internally by the websocket library and cannot be +used. + +[def "-command"] + +This option is used internally by the websocket library and cannot be +used. + +[def "-protocol"] + +This option specifies a list of application protocols to handshake +with the server. This protocols might help the server triggering +application specific features. + +[def "-timeout"] + +This option is supported, but will implemented as part of the library +to enable a number of finalising cleanups. + +[list_end] + +[call [cmd ::websocket::send] [arg sock] [arg type] [opt [arg msg]] [opt [arg final]]] + +This command will send a fragment or a control message to the remote +end of the WebSocket identified by [arg sock]. The type of the +message specified in [arg type] can either be an integer according to +the specification or (preferrably) one of the following case +insensitive strings: "text", "binary" or "ping". The content of the +message to send to the remote end is contained in [arg msg] and +message fragmentation is made possible by the setting the argument +[arg final] to non-true, knowing that the type of each fragment has +then to be the same. + +The command returns the number of bytes that were effectively sent, or +-1 on errors. Serious errors, such as when [arg sock] does not +identify a known WebSocket or when the connection is not stable yet +will generate errors that must be catched. + +[call [cmd ::websocket::server] [arg sock]] + +This command registers the (accept) socket [arg sock] as the +identifier fo an HTTP server that is capable of doing WebSockets. +Paths onto which this server will listen for incoming connections +should be declared using [cmd ::websocket::live]. + +[call [cmd ::websocket::live] [arg sock] [arg path] [arg cb] [opt [arg proto]]] + +This procedure registers callbacks that will be performed on a +WebSocket compliant server registered with [cmd ::websocket::server]] +whenever a client connects to a matching path and protocol. +[arg sock] is the listening socket of the websocket compliant server +declared using [cmd ::websocket::server]. [arg path] is a glob-style +path to match in client request, whenever this will occur. [arg cb] +is the command to callback (see Callbacks). [arg proto] is a +glob-style protocol name matcher. + +[call [cmd ::websocket::test] [arg srvSock] [arg cliSock] [arg path] [opt [arg hdrs]] [opt [arg qry]]] + +This procedure will test if the connection from an incoming client on +socket [arg cliSock] and on the path [arg path] is the opening of a +WebSocket stream within a known server [arg srvSock]. The incoming +request 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 text is made by analysing the content of +the headers [arg hdrs] which should contain a dictionary list of the +HTTP headers of the incoming client connection. + +The command will return [const 1] if this is an incoming WebSocket +upgrade request and [const 0] otherwise. + +[call [cmd ::websocket::upgrade] [arg sock]] + +Upgrade the socket [arg sock] that had been deemed by +[cmd ::websocket::test] to be a WebSocket connection request to a true +WebSocket as recognised by this library. As a result, the necessary +connection handshake will be sent to the client, and the command will +arrange for relevant callbacks to be made during the life of the +WebSocket, notably using the specifications described by +[cmd ::websocket::live]. + +[call [cmd ::websocket::takeover] [arg sock] [arg handler] [opt [arg server]]] + +Take over the existing opened socket [arg sock] to implement sending +and receiving WebSocket framing on top of the socket. The procedure +arranges for [arg handler] to be called back whenever messages, +control messages or other important internal events are received or +occured. [arg server] defaults to [const 0] and can be set to +[const 1] (or a boolean that evaluates to true) to specify that this is a +WebSocket within a server. Apart from specificities in the protocol, +servers should ping their clients at regular intervals in order to +keep the connection opened at all time. When [arg server] is set to +true, the library will arrange to send these pings automatically. + +[call [cmd ::websocket::conninfo] [arg sock] [arg what]] + +Provides callers with some introspection facilities in order to get +some semi-internal information about an existing websocket +connection. Depending on the value of the [arg what] argument, the +procedure returns the following piece of information: + +[list_begin definitions] +[def [const "peername"]] Name (preferred) or IP of remote end. +[def [const "sockname"]] or [const "name"] Name or IP of local end. +[def [const "closed"]] [const 1] if the connection is closed, [const 0] otherwise +[def [const "client"]] [const 1] if the connection is a client websocket, [const 0] otherwise +[def [const "server"]] [const 1] if the connection is a server websocket, [const 0] otherwise +[def [const "type"]] [const "server"] if the connection is a server websocket, [const "client"] otherwise. +[def [const "handler"]] The handler command associated to the websocket +[def [const "state"]] The state of the websocket, which can be one of: +[list_begin definitions] + +[def [const "CONNECTING"]] Connection to remote end is in progress. +[def [const "CONNECTED"]] Connection is connected to remote end. +[def [const "CLOSED"]] Connection is closed. +[list_end] +[list_end] + +[call [cmd ::websocket::find] [opt [arg host]] [opt [arg port]]] + +Look among existing websocket connections for the ones that match the +hostname and port number filters passed as parameters. This lookup +takes the remote end into account and the [arg host] argument is +matched both against the hostname (whenever available) and the IP +address of the remote end. Both the [arg host] and [arg port] +arguments are glob-style string matching filters and default to +[const "*"], i.e. will match any host and/or port number. + +[call [cmd ::websocket::configure] [arg sock] [arg args]] + +This command takes a number of dash-led options (and their values) to +configure the behaviour of an existing websocket connection. The +recognised options are the following (they can be shortened to the +lowest common denominator): + +[list_begin definitions] +[def [const "-keepalive"]] is the number of seconds between each +keepalive pings being sent along the connection. A zero or negative +number will effectively turn off the feature. In servers, +[const "-keepalive"] defaults to 30 seconds, and in clients, no pings +are initiated. +[def [const "-ping"]] is the text that is used during the automated +pings. This text defaults to the empty string, leading to an empty ping. +[list_end] + +[call [cmd ::websocket::loglevel] [opt [arg loglvl]]] + +Set or query the log level of the library, which defaults to error. +Logging is built on top of the logger module, and the library makes +use of the following levels: [const debug], [const info], [const notice], +[const warn] and [const error]. When called with no argument, this procedure will +simply return the current log level. Otherwise [arg loglvl] should contain +the desired log level. + +[call [cmd ::websocket::close] [arg sock] [opt [arg code]] [opt [arg reason]]] + +Gracefully close a websocket that was directly or indirectly passed to +[cmd ::websocket::takeover]. The procedure will optionally send the +[arg code] and describing [arg reason] as part of the closure handshake. +Good defaults are provided, so that reasons for a number of known codes will +be sent back. Only the first 125 characters of a reason string will be kept and +sent as part of the handshake. The known codes are: +[list_begin definitions] +[def [const 1000]] Normal closure (the default [arg code] when none provided). +[def [const 1001]] Endpoint going away +[def [const 1002]] Protocol Error +[def [const 1003]] Received incompatible data type +[def [const 1006]] Abnormal closure +[def [const 1007]] Received data not consistent with type +[def [const 1008]] Policy violation +[def [const 1009]] Received message too big +[def [const 1010]] Missing extension +[def [const 1011]] Unexpected condition +[def [const 1015]] TLS handshake error +[list_end] + + + +[list_end] + +[section Examples] + +[para] + +The following example opens a websocket connection to the echo +service, waits 400ms to ensure that the connection is really +established and sends a single textual message which should be echoed +back by the echo service. A real example would probably use the +[const "connect"] callback to know when connection to the remote +server has been establish and would only send data at that time. + +[example_begin] +package require websocket +::websocket::loglevel debug + +proc handler { sock type msg } { + switch -glob -nocase -- $type { + co* { + puts "Connected on $sock" + } + te* { + puts "RECEIVED: $msg" + } + cl* - + dis* { + } + } + +} + +proc test { sock } { + puts "[lb]::websocket::conninfo $sock type[rb] from [lb]::websocket::conninfo $sock sockname[rb] to [lb]::websocket::conninfo $sock peername[rb]" + + ::websocket::send $sock text "Testing, testing..." +} + +set sock [lb]::websocket::open ws://echo.websocket.org/ handler[rb] +after 400 test $sock +vwait forever +[example_end] + +[include ../common-text/tls-security-notes.inc] + +[vset CATEGORY websocket] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/websocket/websocket.tcl b/tcllib/modules/websocket/websocket.tcl new file mode 100644 index 0000000..c433bc2 --- /dev/null +++ b/tcllib/modules/websocket/websocket.tcl @@ -0,0 +1,1754 @@ +################## +## Module Name -- websocket +## Original Author -- Emmanuel Frecon - emmanuel@sics.se +## Patches -- Adrián Medraño Calvo - amcalvo@prs.de +## 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.5 + +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 "error" + maxlength 16777216 + ws_magic "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" + ws_version 13 + id_gene 0 + whitespace " \t" + tchar {!#$%&'*+-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz|~} + -keepalive 30 + -ping "" + } + # Build ASCII case-insensitive mapping table. See + # <http://tools.ietf.org/html/rfc6455#section-2.1>. + for {set i 0x41} {$i <= 0x5A} {incr i} { + lappend WS(lowercase) [format %c $i] [format %c [expr {$i + 0x20}]] + }; unset i; + 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" + ThrowError "$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. +# ping Ping complete message. +# pong Pong complete message. +# connect Notification of successful connection. +# disconnect Disconnection from remote end. +# close Pending closure of connection +# timeout Notification of connection timeout. +# error Notification of error conditions. +# +# The handler is expected to be a command prefix, and the values +# of parameters sock, type and msg are appended as arguments +# when evaluating it. +# +# 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" + ThrowError "$sock is not a WebSocket" + } + upvar \#0 $varname Connection + set handler $Connection(handler) + } + + if { [catch [list {*}$handler $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" + ThrowError "$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 { [info exists TYPES($opcode)] } { + set type $TYPES($opcode) + } else { + set type <opcode-$opcode> + } + + return $type +} + + +# ::websocket::validate -- Validate incoming client connections for WebSocket +# +# This procedure checks whether a set of headers form a valid +# WebSocket opening handshake. If so, it returns values +# important for constructing the closing handshake. +# +# The following aspects are checked: +# - A valid Connection header +# - A valid Upgrade header +# - A valid Sec-Websocket-Version header +# - A valid Sec-Websocket-Key header +# +# These other are left to the invoker to check: +# - Host contains server's authority. +# - Origin is allowed. +# - Sec-Websocket-Protocols contains a supported protocol. +# +# Arguments: +# hdrs Dictionary with HTTP header field names and their values. +# +# Results: +# An empty list if the headers do not constitute a valid WebSocket opening +# handshake. Otherwise, a dictionary with keys 'key', 'version' +# and, optionally, 'protocols'. +# +# Side Effects: +# None. +proc ::websocket::validate {hdrs} { + variable WS + set res [dict create] + + set upgrading 0; + set websocket 0; + foreach {k v} $hdrs { + switch -exact -- [ASCIILowercase $k] { + connection { + foreach v [SplitCommaSeparated $v] { + if {"upgrade" eq [ASCIILowercase $v]} { + set upgrading 1 + break + } + } + if {!$upgrading} { + ThrowError "No 'Connect' header with 'upgrade' token found" HANDSHAKE CONNECTION + } + } + upgrade { + # May be a list, see + # <http://tools.ietf.org/html/rfc7230#section-6.7> and + # <http://tools.ietf.org/html/rfc6455#section-4.1>. + foreach v [SplitCommaSeparated $v] { + # The protocol-name may be followed by a slash and a + # protocol-version. Ignore the version, look only at the + # protocol-name. See + # <http://tools.ietf.org/html/rfc7230#section-6.7>. + regexp {^[^/]+$} $v v + if { "websocket" eq [ASCIILowercase $v] } { + set websocket 1 + break + } + } + if {!$websocket} { + ThrowError "No 'Upgrade' header with 'websocket' token found" HANDSHAKE UPGRADE + } + } + sec-websocket-version { + set version [string trim $v $WS(whitespace)] + if {$version ne $WS(ws_version)} { + ThrowError "Invalid WebSocket version '${version}'" HANDSHAKE VERSION + } else { + dict set res version $version + } + } + sec-websocket-key { + set key [string trim $v $WS(whitespace)] + if {24 != [string length $key]} { + ThrowError "Invalid WebSocket key length" HANDSHAKE KEY + } elseif {![regexp {^[a-zA-Z0-9+/]*={0,2}$} $key]} { + ThrowError "Invalid WebSocket key: not base64" HANDSHAKE KEY + } + dict set res key $key + } + sec-websocket-protocol { + # There might be multiple "sec-websocket-protocol" headers. + # See <http://tools.ietf.org/html/rfc6455#section-11.3.4>. + set protocols [SplitCommaSeparated $v] + # Must be valid tokens. + foreach protocol $protocols { + foreach c [split $protocol ""] { + if {$c in $WS(tchar)} { + ThrowError "Invalid protocol name '${protocol}'" HANDSHAKE PROTOCOL; + } + } + } + dict lappend res protocols {*}$protocols; + } + } + } + if {![dict exists $res version]} { + ThrowError "No WebSocket version specified" HANDSHAKE VERSION + } + if {![dict exists $res key]} { + ThrowError "No WebSocket key specified" HANDSHAKE KEY + } + + return $res +} + +# ::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" + ThrowError "$srvSock is not a WebSocket" + } + upvar \#0 $varname Server + + if {[catch {validate $hdrs} res]} { + return 0 + } + set protos [dict get $res protocols]; + set key [dict get $res key]; + + # 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] + # URL paths comparison should be case-sensitive. See + # <http://tools.ietf.org/html/rfc2616#section-3.2.3>. + if { [string match $ptn $path] \ + && ( ![llength $protos] || $idx >= 0 ) } { + set found(protocol) [expr {$idx >= 0? [lindex $protos $idx] : ""}] + set found(live) $cb + break + } + } + + # Stop if cannot agree on subprotocol. + if {![info exists found]} { + ${log}::warn "Cannot find any handler for $path" + 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 + set Client(accept) [sec-websocket-accept $key] + set Client(protos) $protos + set Client(live) $found(live) + set Client(protocol) $found(protocol) + + # 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" + ThrowError "$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 + # + # 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). + takeover $sock $Client(live) 1 [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" + ThrowError "$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" + ThrowError "$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 } { + ThrowError \ + "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) } { + ThrowError \ + "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()*(1<<32))}] + 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" + ThrowError "$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 bytes 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) + } + 10 { + Push $sock pong $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. +# +# The handler should be a command prefix, to be evaluated with +# socket handle, the message type and the message appended. +# +# 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. +# info Additional information to pass to the handler upon successful +# connection. +# +# Results: +# None. +# +# Side Effects: +# The handler is invoked with type 'connect' on successful connection. +proc ::websocket::takeover { sock handler { server 0 } { info {} }} { + 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] + } + } else { + ${log}::warn "Cannot get remote information from socket: $sockinfo" + } + if { [catch {fconfigure $sock -sockname} sockinfo] == 0 } { + set Connection(sockname) [lindex $sockinfo 1] + if { $Connection(sockname) eq "" } { + set Connection(sockname) [lindex $sockinfo 0] + } + } else { + ${log}::warn "Cannot get local information from socket: $sockinfo" + } + + # 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 + + # Tell the WebSocket handler that the connection is now open. + Push $sock connect $info; + + ${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 + } + } + + set ncode [::http::ncode $token] + if { $ncode == 101 } { + array set HDR [::http::meta $token] + + # Extact security handshake, check against what was expected + # and abort in case of mismatch. + if { [info exists HDR(Sec-WebSocket-Accept)] } { + # Compute security handshake + set accept [sec-websocket-accept $OPEN(nonce)] + 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 { [info exists HDR(Sec-WebSocket-Protocol)] } { + 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. Tell the handler which protocol was + # chosen. + takeover $sock $OPEN(handler) 0 $proto + } else { + Push \ + $sock \ + error \ + "HTTP error code $ncode when establishing WebSocket connection with $OPEN(url)" \ + $OPEN(handler) + } + + ::http::cleanup $token + unset $opener; # Always unset the temporary connection opening + # array + return 0 +} + + +# ::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. +# token HTTP state array. +# +# Results: +# None. +# +# Side Effects: +# None. +proc ::websocket::Finished { opener token } { + if {[::http::status $token] ne "timeout"} { + upvar \#0 $opener OPEN + if { [info exists OPEN(timeout)] } { + ::after cancel $OPEN(timeout); + unset OPEN(timeout); + } + } + + 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. +# token HTTP state array. +# +# Results: +# None. +# +# Side Effects: +# Reset the HTTP connection, which will (probably) close the +# socket. +proc ::websocket::Timeout { opener token } { + variable WS + variable log + + if { [info exists $opener] } { + upvar \#0 $opener OPEN + + set sock [HTTPSocket $token] + Push $sock timeout \ + "Timeout when connecting to $OPEN(url)" $OPEN(handler) + ::http::reset $token "timeout"; + ::http::cleanup $token + + # 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 { [info exists htstate(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 prefix to invoke on data reception or event occurrence +# 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 [regsub -nocase {^ws} $url "http"] + + # 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 } { + ThrowError "$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 + AddToken HDR Connection "Upgrade" + AddToken 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] + + # Adding our own handler to intercept the socket once connection + # has been opened and established properly would be logical, but + # does not work in practice since this forces the HTTP library to + # perform a HTTP 1.0 request. Instead, we arrange to be called + # back via -command. We force -keepalive to make sure the HTTP + # library does not insert a "Connection: close" directive in the + # headers, and really make sure to do whatever we can to have a + # HTTP 1.1 connection. + lappend cmd \ + -command [list [namespace current]::Finished $varname] \ + -keepalive 1 \ + -protocol 1.1 + + # Now open the connection to the remote server using the HTTP + # package... + set sock "" + if { [catch $cmd token] } { + unset $varname; # Free opening context, we won't need it! + ThrowError "Error while opening WebSocket connection to $url: $token" + } else { + set sock [HTTPSocket $token] + if { $sock ne "" } { + # Create connection context. + New $sock $handler + if { $timeout > 0 } { + set OPEN(timeout) \ + [after $timeout [list [namespace current]::Timeout $varname $token]] + } + } else { + ${log}::warn "Cannot extract socket from HTTP token, failure" + # Call the timeout to get rid of internal states + Timeout $varname $token + } + } + + 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" + ThrowError "$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 { + ThrowError "$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" + ThrowError "$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 } { + ThrowError "$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 + } + } + } +} + +# ::websocket::sec-websocket-accept -- Construct Sec-Websocket-Accept field value. +# +# Construct the value for the Sec-Websocket-Accept header field, as +# defined by (RFC6455 4.2.2.5.4). +# +# See <http://tools.ietf.org/html/rfc6455#section-4.2.2>. +# +# Arguments: +# key The value of the Sec-Websocket-Key header field in the client's +# handshake. +# +# Results: +# The value for the Sec-Websocket-Accept header field. +# +# Side Effects: +# None. +proc ::websocket::sec-websocket-accept { key } { + variable WS + set sec ${key}$WS(ws_magic) + return [::base64::encode [sha1::sha1 -bin $sec]] +} + +# ::websocket::SplitCommaSeparated -- Extract elements from comma-separated headers +# +# Extract elements from a comma separated header's value, ignoring empty +# elements and linear whitespace. +# +# See <http://tools.ietf.org/html/rfc7230#section-7>. +# +# Arguments: +# value A header's value, consisting of a comma separated list of +# elements. +# +# Results: +# A list of values. +# +# Side Effects: +# None. +proc ::websocket::SplitCommaSeparated { csl } { + variable WS + set r [list] + foreach e [split $csl ,] { + # Trim OWS. + set v [string trim $e $WS(whitespace)] + # There might be empty elements. + if {"" ne $v} { + lappend r $v + } + } + return $r +} + +# ::websocket::ASCIILowercase +# +# Convert a string to ASCII lowercase. +# +# See <http://tools.ietf.org/html/rfc6455#section-2.1>. +# +# Arguments: +# str The string to convert +# +# Results: +# The string converted to ASCII lowercase. +# +# Side Effects: +# None. +proc ::websocket::ASCIILowercase { str } { + variable WS + return [string map $WS(lowercase) $str] +} + + +# ::websocket::AddToken +# +# Ensures a token is included in hdr's header field value. +# +# Arguments: +# hdrsName Name of an array variable on caller's scope whose +# keys are header names and values are header values. +# hdr Header name, matched case-insensitively. +# token Token to include. +# +# Results: +# Nothing. +# +# Side Effects: +# Modifies variable named hdrsName in caller's scope. +proc ::websocket::AddToken { hdrsName hdr token } { + ::upvar 1 $hdrsName hdrs; + set hdrname [lsearch -exact -nocase -inline [array names hdrs] $hdr] + if {"" ne $hdrname} { + append hdrs($hdrname) ", $token" + } else { + set hdrs($hdr) $token + } +} + +# ::websocket::ThrowError +# +# Consistent error reporting. All errors from the WebSocket +# library have the word WEBSOCKET as the first element in the +# -errorcode list. +# +# Arguments: +# msg Error message. +# ?errorcodes...? Optional. Additional error codes. +# +# Results: +# An error return value to the caller of the caller. +# +# Side Effects: +# None. +proc ::websocket::ThrowError {msg args} { + return \ + -level 2 \ + -code error \ + -errorcode [list WEBSOCKET {*}$args] \ + $msg; +} + +package provide websocket 1.4 |