Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

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