[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[ELPA-diffs] elpa r429: Add websocket git revno bc5c2a2ee2b993a18e8e23ed
|
From: |
Stefan Monnier |
|
Subject: |
[ELPA-diffs] elpa r429: Add websocket git revno bc5c2a2ee2b993a18e8e23ed725829d403508753. |
|
Date: |
Thu, 01 Aug 2013 18:08:27 +0000 |
|
User-agent: |
Bazaar (2.6b2) |
------------------------------------------------------------
revno: 429
revision-id: address@hidden
parent: address@hidden
committer: Stefan Monnier <address@hidden>
branch nick: elpa
timestamp: Thu 2013-08-01 14:08:23 -0400
message:
Add websocket git revno bc5c2a2ee2b993a18e8e23ed725829d403508753.
added:
packages/websocket/ websocket-20130801180751-nzyk3vosqzza6c10-1
packages/websocket/COPYING copying-20130801180751-nzyk3vosqzza6c10-2
packages/websocket/README.org readme.org-20130801180751-nzyk3vosqzza6c10-3
packages/websocket/testserver.py
testserver.py-20130801180751-nzyk3vosqzza6c10-4
packages/websocket/websocket-functional-test.el
websocketfunctionalt-20130801180751-nzyk3vosqzza6c10-5
packages/websocket/websocket-test.el
websockettest.el-20130801180751-nzyk3vosqzza6c10-6
packages/websocket/websocket.el websocket.el-20130801180751-nzyk3vosqzza6c10-7
=== added directory 'packages/websocket'
=== added file 'packages/websocket/COPYING'
--- a/packages/websocket/COPYING 1970-01-01 00:00:00 +0000
+++ b/packages/websocket/COPYING 2013-08-01 18:08:23 +0000
@@ -0,0 +1,339 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with this program; if not, write to the Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.
\ No newline at end of file
=== added file 'packages/websocket/README.org'
--- a/packages/websocket/README.org 1970-01-01 00:00:00 +0000
+++ b/packages/websocket/README.org 2013-08-01 18:08:23 +0000
@@ -0,0 +1,31 @@
+* Description
+This is a elisp library for websocket clients to talk to websocket
+servers, and for websocket servers to accept connections from
+websocket clients. This library is designed to be used by other
+library writers, to write apps that use websockets, and is not useful
+by itself.
+
+An example of how to use the library is in the
+[[https://github.com/ahyatt/emacs-websocket/blob/master/websocket-functional-test.el][websocket-functional-test.el]]
file.
+
+This library is compatible with emacs 23 and 24, although only emacs
+24 support secure websockets.
+
+* Version release checklist
+
+Each version that is released should be checked with this checklist:
+
+- [ ] All ert test passing
+- [ ] Functional test passing on emacs 23 and 24
+- [ ] websocket.el byte compiling cleanly.
+
+* Existing clients:
+
+- [[https://github.com/tkf/emacs-ipython-notebook][Emacs IPython Notebook]]
+- [[https://github.com/syohex/emacs-realtime-markdown-viewer][Emacs Realtime
Markdown Viewer]]
+- [[https://github.com/jscheid/kite][Kite]]
+
+If you are using this module for your own emacs package, please let me
+know by editing this file, adding your project, and sending a pull
+request to this repository.
+
=== added file 'packages/websocket/testserver.py'
--- a/packages/websocket/testserver.py 1970-01-01 00:00:00 +0000
+++ b/packages/websocket/testserver.py 2013-08-01 18:08:23 +0000
@@ -0,0 +1,34 @@
+import logging
+import tornado
+import tornado.web
+from tornado import httpserver
+from tornado import ioloop
+from tornado import websocket
+
+
+class EchoWebSocket(websocket.WebSocketHandler):
+
+ def open(self):
+ logging.info("OPEN")
+
+ def on_message(self, message):
+ logging.info(u"ON_MESSAGE: {0}".format(message))
+ self.write_message(u"You said: {0}".format(message))
+
+ def on_close(self):
+ logging.info("ON_CLOSE")
+
+ def allow_draft76(self):
+ return False
+
+
+if __name__ == "__main__":
+ import tornado.options
+ tornado.options.parse_command_line()
+ application = tornado.web.Application([
+ (r"/", EchoWebSocket),
+ ])
+ server = httpserver.HTTPServer(application)
+ server.listen(9999)
+ logging.info("STARTED: Server start listening")
+ ioloop.IOLoop.instance().start()
=== added file 'packages/websocket/websocket-functional-test.el'
--- a/packages/websocket/websocket-functional-test.el 1970-01-01 00:00:00
+0000
+++ b/packages/websocket/websocket-functional-test.el 2013-08-01 18:08:23
+0000
@@ -0,0 +1,133 @@
+;; Simple functional testing
+;; Usage: emacs -batch -Q -L . -l websocket-functional-test.el
+;;
+;; Note: this functional tests requires that you have python with the
+;; Tornado web server. See http://www.tornadoweb.org/en/stable/ for
+;; information on aquiring.
+
+(require 'tls) ;; tests a particular bug we had on emacs 23
+(setq debug-on-error t)
+(require 'websocket)
+(eval-when-compile (require 'cl))
+
+;;;;;;;;;;;;;;;;;;;;;;;
+;; Local server test ;;
+;;;;;;;;;;;;;;;;;;;;;;;
+
+(message "Testing with local server")
+
+(setq websocket-debug t)
+
+(defvar wstest-server-buffer (get-buffer-create "*wstest-server*"))
+(defvar wstest-server-name "wstest-server")
+(defvar wstest-server-proc
+ (start-process wstest-server-name wstest-server-buffer
+ "python" "testserver.py" "--log_to_stderr" "--logging=debug"))
+(sleep-for 1)
+
+(defvar wstest-msgs nil)
+(defvar wstest-closed nil)
+
+(message "Opening the websocket")
+
+(defvar wstest-ws
+ (websocket-open
+ "ws://127.0.0.1:9999"
+ :on-message (lambda (websocket frame)
+ (push (websocket-frame-payload frame) wstest-msgs)
+ (message "ws frame: %S" (websocket-frame-payload frame))
+ (error "Test error (expected)"))
+ :on-close (lambda (websocket) (setq wstest-closed t))))
+
+(defun wstest-pop-to-debug ()
+ "Open websocket log buffer. Not used in testing. Just for debugging."
+ (interactive)
+ (pop-to-buffer (websocket-get-debug-buffer-create wstest-ws)))
+
+(sleep-for 0.1)
+(assert (websocket-openp wstest-ws))
+
+(assert (null wstest-msgs))
+
+(websocket-send-text wstest-ws "Hi!")
+
+(sleep-for 0.1)
+(assert (equal (car wstest-msgs) "You said: Hi!"))
+(setf (websocket-on-error wstest-ws) (lambda (ws type err)))
+(websocket-send-text wstest-ws "Hi after error!")
+(sleep-for 0.1)
+(assert (equal (car wstest-msgs) "You said: Hi after error!"))
+
+(websocket-close wstest-ws)
+(assert (null (websocket-openp wstest-ws)))
+
+(stop-process wstest-server-proc)
+(kill-process wstest-server-proc)
+
+;; Make sure the processes are closed. This happens asynchronously,
+;; so let's wait for it.
+(sleep-for 1)
+(assert (null (process-list)) t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Remote server test, with wss ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(when (>= (string-to-int (substring emacs-version 0 2)) 24)
+ (message "Testing with wss://echo.websocket.org")
+ (setq wstest-ws
+ (websocket-open
+ "wss://echo.websocket.org"
+ :on-open (lambda (websocket)
+ (message "Websocket opened"))
+ :on-message (lambda (websocket frame)
+ (push (websocket-frame-payload frame) wstest-msgs)
+ (message "ws frame: %S" (websocket-frame-payload
frame)))
+ :on-close (lambda (websocket)
+ (message "Websocket closed")
+ (setq wstest-closed t)))
+ wstest-msgs nil)
+ (sleep-for 0.3)
+ (assert (websocket-openp wstest-ws))
+ (assert (null wstest-msgs))
+ (websocket-send-text wstest-ws "Hi!")
+ (sleep-for 0.3)
+ (assert (equal (car wstest-msgs) "Hi!"))
+ (websocket-close wstest-ws))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Local client and server ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(message "Testing with emacs websocket server.")
+(message "If this does not pass, make sure your firewall allows the
connection.")
+(setq wstest-closed nil)
+(setq server-conn (websocket-server
+ 9998
+ :on-message (lambda (ws frame)
+ (message "Server received text!")
+ (websocket-send-text ws
+ (websocket-frame-payload frame)))
+ :on-open (lambda (websocket) "Client connection opened!")
+ :on-close (lambda (websocket)
+ (setq wstest-closed t))))
+
+(setq wstest-msgs nil
+ wstest-ws
+ (websocket-open
+ "ws://localhost:9998"
+ :on-message (lambda (websocket frame)
+ (push (websocket-frame-payload frame) wstest-msgs)
+ (message "ws frame: %S" (websocket-frame-payload
frame)))))
+
+(assert (websocket-openp wstest-ws))
+(websocket-send-text wstest-ws "Hi to self!")
+(sleep-for 0.3)
+(assert (equal (car wstest-msgs) "Hi to self!"))
+(websocket-server-close server-conn)
+(assert wstest-closed)
+(websocket-close wstest-ws)
+
+(sleep-for 1)
+(assert (null (process-list)) t)
+(message "\nAll tests passed!\n")
=== added file 'packages/websocket/websocket-test.el'
--- a/packages/websocket/websocket-test.el 1970-01-01 00:00:00 +0000
+++ b/packages/websocket/websocket-test.el 2013-08-01 18:08:23 +0000
@@ -0,0 +1,596 @@
+;; websocket-test.el --- Unit tests for the websocket layer
+
+;; Copyright (c) 2010 Andrew Hyatt
+;;
+;; Author: Andrew Hyatt <ahyatt at gmail dot com>
+;; Maintainer: Andrew Hyatt <ahyatt at gmail dot com>
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301, USA.
+
+;;; Commentary:
+;; This defines and runs ert unit tests. You can download ert from:
+;; http://github.com/ohler/ert, it also comes with Emacs 24 and above.
+
+(require 'ert)
+(require 'websocket)
+(eval-when-compile (require 'cl))
+
+(ert-deftest websocket-genbytes-length ()
+ (loop repeat 100
+ do (should (= (string-bytes (websocket-genbytes 16)) 16))))
+
+(ert-deftest websocket-calculate-accept ()
+ ;; This example comes straight from RFC 6455
+ (should
+ (equal "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="
+ (websocket-calculate-accept "dGhlIHNhbXBsZSBub25jZQ=="))))
+
+(defconst websocket-test-hello "\x81\x05\x48\x65\x6c\x6c\x6f"
+ "'Hello' string example, taken from the RFC.")
+
+(defconst websocket-test-masked-hello
+ "\x81\x85\x37\xfa\x21\x3d\x7f\x9f\x4d\x51\x58"
+ "'Hello' masked string example, taken from the RFC.")
+
+(ert-deftest websocket-get-bytes ()
+ (should (equal #x5 (websocket-get-bytes "\x5" 1)))
+ (should (equal #x101 (websocket-get-bytes "\x1\x1" 2)))
+ (should (equal #xffffff
+ (websocket-get-bytes "\x0\x0\x0\x0\x0\xFF\xFF\xFF" 8)))
+ (should-error (websocket-get-bytes "\x0\x0\x0\x1\x0\x0\x0\x1" 8)
+ :type 'websocket-unparseable-frame)
+ (should-error (websocket-get-bytes "\x0\x0\x0" 3))
+ (should-error (websocket-get-bytes "\x0" 2) :type
'websocket-unparseable-frame))
+
+(ert-deftest websocket-get-opcode ()
+ (should (equal 'text (websocket-get-opcode websocket-test-hello))))
+
+(ert-deftest websocket-get-payload-len ()
+ (should (equal '(5 . 1)
+ (websocket-get-payload-len
+ (substring websocket-test-hello 1))))
+ (should (equal '(200 . 3)
+ (websocket-get-payload-len
+ (bindat-pack '((:len u8) (:val u16))
+ `((:len . 126)
+ (:val . 200))))))
+ ;; we don't want to hit up any limits even on strange emacs builds,
+ ;; so this test has a pretty small test value
+ (should (equal '(70000 . 9)
+ (websocket-get-payload-len
+ (bindat-pack '((:len u8) (:val vec 2 u32))
+ `((:len . 127)
+ (:val . [0 70000])))))))
+
+(ert-deftest websocket-read-frame ()
+ (should (equal (make-websocket-frame :opcode 'text :payload "Hello"
+ :length (length websocket-test-hello)
+ :completep t)
+ (websocket-read-frame websocket-test-hello)))
+ (should (equal (make-websocket-frame :opcode 'text :payload "Hello"
+ :length (length websocket-test-hello)
+ :completep t)
+ (websocket-read-frame (concat websocket-test-hello
+ "should-not-be-read"))))
+ (should (equal (make-websocket-frame :opcode 'text :payload "Hello"
+ :length (length
websocket-test-masked-hello)
+ :completep t)
+ (websocket-read-frame websocket-test-masked-hello)))
+ (should (equal (make-websocket-frame :opcode 'text :payload "Hello"
+ :length (length websocket-test-hello)
+ :completep nil)
+ (websocket-read-frame
+ (concat (unibyte-string
+ (logand (string-to-char
+ (substring websocket-test-hello 0 1))
+ 127))
+ (substring websocket-test-hello 1)))))
+ (dotimes (i (- (length websocket-test-hello) 1))
+ (should-not (websocket-read-frame
+ (substring websocket-test-hello 0
+ (- (length websocket-test-hello) (+ i 1))))))
+ (dotimes (i (- (length websocket-test-masked-hello) 1))
+ (should-not (websocket-read-frame
+ (substring websocket-test-masked-hello 0
+ (- (length websocket-test-masked-hello) (+ i
1)))))))
+
+(defun websocket-test-header-with-lines (&rest lines)
+ (mapconcat 'identity (append lines '("\r\n")) "\r\n"))
+
+(ert-deftest websocket-verify-response-code ()
+ (should (websocket-verify-response-code "HTTP/1.1 101"))
+ (should
+ (eq 400 (cdr (should-error (websocket-verify-response-code "HTTP/1.1 400")
+ :type 'websocket-received-error-http-response))))
+ (should
+ (eq 200 (cdr (should-error (websocket-verify-response-code "HTTP/1.1
200"))))))
+
+(ert-deftest websocket-verify-headers ()
+ (let ((accept "Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=")
+ (invalid-accept "Sec-WebSocket-Accept: bad")
+ (upgrade "Upgrade: websocket")
+ (connection "Connection: upgrade")
+ (ws (websocket-inner-create
+ :conn "fake-conn" :url "ws://foo/bar"
+ :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="))
+ (ws-with-protocol
+ (websocket-inner-create
+ :conn "fake-conn" :url "ws://foo/bar"
+ :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="
+ :protocols '("myprotocol")))
+ (ws-with-extensions
+ (websocket-inner-create
+ :conn "fake-conn" :url "ws://foo/bar"
+ :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="
+ :extensions '("ext1" "ext2"))))
+ (should (websocket-verify-headers
+ ws
+ (websocket-test-header-with-lines accept upgrade connection)))
+ (should-error
+ (websocket-verify-headers
+ ws
+ (websocket-test-header-with-lines invalid-accept upgrade connection))
+ :type 'websocket-invalid-header)
+ (should-error (websocket-verify-headers
+ ws
+ (websocket-test-header-with-lines upgrade connection))
+ :type 'websocket-invalid-header)
+ (should-error (websocket-verify-headers
+ ws
+ (websocket-test-header-with-lines accept connection))
+ :type 'websocket-invalid-header)
+ (should-error (websocket-verify-headers
+ ws
+ (websocket-test-header-with-lines accept upgrade))
+ :type 'websocket-invalid-header)
+ (should-error (websocket-verify-headers
+ ws-with-protocol
+ (websocket-test-header-with-lines accept upgrade
connection))
+ :type 'websocket-invalid-header)
+ (should-error
+ (websocket-verify-headers
+ ws-with-protocol
+ (websocket-test-header-with-lines accept upgrade connection
+ "Sec-Websocket-Protocol: foo"))
+ :type 'websocket-invalid-header)
+ (should
+ (websocket-verify-headers
+ ws-with-protocol
+ (websocket-test-header-with-lines accept upgrade connection
+ "Sec-Websocket-Protocol: myprotocol")))
+ (should (equal '("myprotocol")
+ (websocket-negotiated-protocols ws-with-protocol)))
+ (should-error
+ (websocket-verify-headers
+ ws-with-extensions
+ (websocket-test-header-with-lines accept upgrade connection
+ "Sec-Websocket-Extensions: foo")))
+ (should
+ (websocket-verify-headers
+ ws-with-extensions
+ (websocket-test-header-with-lines
+ accept upgrade connection "Sec-Websocket-Extensions: ext1, ext2; a=1")))
+ (should (equal '("ext1" "ext2; a=1")
+ (websocket-negotiated-extensions ws-with-extensions)))
+ (should
+ (websocket-verify-headers
+ ws-with-extensions
+ (websocket-test-header-with-lines accept upgrade connection
+ "Sec-Websocket-Extensions: ext1"
+ "Sec-Websocket-Extensions: ext2;
a=1")))
+ (should (equal '("ext1" "ext2; a=1")
+ (websocket-negotiated-extensions ws-with-extensions)))))
+
+(ert-deftest websocket-create-headers ()
+ (let ((system-name "mysystem")
+ (base-headers (concat "Host: www.example.com\r\n"
+ "Upgrade: websocket\r\n"
+ "Connection: Upgrade\r\n"
+ "Sec-WebSocket-Key: key\r\n"
+ "Origin: mysystem\r\n"
+ "Sec-WebSocket-Version: 13\r\n")))
+ (should (equal (concat base-headers "\r\n")
+ (websocket-create-headers "ws://www.example.com/path"
+ "key" nil nil)))
+ (should (equal (concat base-headers
+ "Sec-WebSocket-Protocol: protocol\r\n\r\n")
+ (websocket-create-headers "ws://www.example.com/path"
+ "key" '("protocol") nil)))
+ (should (equal
+ (concat base-headers
+ "Sec-WebSocket-Extensions: ext1; a; b=2, ext2\r\n\r\n")
+ (websocket-create-headers "ws://www.example.com/path"
+ "key" nil
+ '(("ext1" . ("a" "b=2"))
+ ("ext2")))))))
+
+(ert-deftest websocket-process-frame ()
+ (let* ((sent)
+ (processed)
+ (deleted)
+ (websocket (websocket-inner-create
+ :conn t :url t
+ :on-message (lambda (websocket frame)
+ (setq
+ processed
+ (websocket-frame-payload frame)))
+ :accept-string t)))
+ (dolist (opcode '(text binary continuation))
+ (setq processed nil)
+ (should (equal
+ "hello"
+ (progn
+ (funcall (websocket-process-frame
+ websocket
+ (make-websocket-frame :opcode opcode :payload "hello")))
+ processed))))
+ (setq sent nil)
+ (flet ((websocket-send (websocket content) (setq sent content)))
+ (should (equal
+ (make-websocket-frame :opcode 'pong :completep t)
+ (progn
+ (funcall (websocket-process-frame websocket
+ (make-websocket-frame :opcode
'ping)))
+ sent))))
+ (flet ((delete-process (conn) (setq deleted t)))
+ (should (progn
+ (funcall
+ (websocket-process-frame websocket
+ (make-websocket-frame :opcode
'close)))
+ deleted)))))
+
+(ert-deftest websocket-process-frame-error-handling ()
+ (let* ((error-called)
+ (websocket (websocket-inner-create
+ :conn t :url t :accept-string t
+ :on-message (lambda (websocket frame)
+ (message "In on-message")
+ (error "err"))
+ :on-error (lambda (ws type err)
+ (should (eq 'on-message type))
+ (setq error-called t)))))
+ (funcall (websocket-process-frame websocket
+ (make-websocket-frame :opcode 'text
+ :payload "hello")))
+ (should error-called)))
+
+(ert-deftest websocket-to-bytes ()
+ ;; We've tested websocket-get-bytes by itself, now we can use it to
+ ;; help test websocket-to-bytes.
+ (should (equal 30 (websocket-get-bytes (websocket-to-bytes 30 1) 1)))
+ (should (equal 300 (websocket-get-bytes (websocket-to-bytes 300 2) 2)))
+ (should (equal 70000 (websocket-get-bytes (websocket-to-bytes 70000 8) 8)))
+ (should-error (websocket-to-bytes 536870912 8) :type
'websocket-frame-too-large)
+ (should-error (websocket-to-bytes 30 3))
+ (should-error (websocket-to-bytes 300 1))
+ ;; I'd like to test the error for 32-byte systems on 8-byte lengths,
+ ;; but elisp does not allow us to temporarily set constants such as
+ ;; most-positive-fixnum.
+ )
+
+(ert-deftest websocket-encode-frame ()
+ ;; We've tested websocket-read-frame, now we can use that to help
+ ;; test websocket-encode-frame.
+ (let ((websocket-mask-frames nil))
+ (should (equal
+ websocket-test-hello
+ (websocket-encode-frame
+ (make-websocket-frame :opcode 'text :payload "Hello" :completep
t))))
+ (dolist (len '(200 70000))
+ (let ((long-string (make-string len ?x)))
+ (should (equal long-string
+ (websocket-frame-payload
+ (websocket-read-frame
+ (websocket-encode-frame
+ (make-websocket-frame :opcode 'text
+ :payload long-string)))))))))
+ (let ((websocket-mask-frames t))
+ (flet ((websocket-genbytes (n) (substring websocket-test-masked-hello 2
6)))
+ (should (equal websocket-test-masked-hello
+ (websocket-encode-frame
+ (make-websocket-frame :opcode 'text :payload "Hello"
+ :completep t))))))
+ (should-not
+ (websocket-frame-completep
+ (websocket-read-frame
+ (websocket-encode-frame (make-websocket-frame :opcode 'text
+ :payload "Hello"
+ :completep nil)))))
+ (dolist (opcode '(close ping pong))
+ (should (equal
+ opcode
+ (websocket-frame-opcode
+ (websocket-read-frame
+ (websocket-encode-frame (make-websocket-frame :opcode opcode
+ :completep
t))))))))
+
+(ert-deftest websocket-close ()
+ (let ((sent-frames)
+ (processes-deleted))
+ (flet ((websocket-send (websocket frame) (push frame sent-frames))
+ (websocket-openp (websocket) t)
+ (kill-buffer (buffer))
+ (delete-process (proc))
+ (process-buffer (conn) (add-to-list 'processes-deleted conn)))
+ (websocket-close (websocket-inner-create
+ :conn "fake-conn"
+ :url t
+ :accept-string t))
+ (should (equal sent-frames (list
+ (make-websocket-frame :opcode 'close
+ :completep t))))
+ (should (equal processes-deleted '("fake-conn"))))))
+
+(ert-deftest websocket-outer-filter ()
+ (let* ((fake-ws (websocket-inner-create
+ :conn t :url t :accept-string t
+ :on-open (lambda (websocket)
+ (should (eq (websocket-ready-state websocket)
+ 'open))
+ (setq open-callback-called t)
+ (error "Ignore me!"))
+ :on-error (lambda (ws type err))))
+ (processed-frames)
+ (frame1 (make-websocket-frame :opcode 'text :payload "foo" :completep
t
+ :length 9))
+ (frame2 (make-websocket-frame :opcode 'text :payload "bar" :completep
t
+ :length 9))
+ (open-callback-called)
+ (websocket-frames
+ (concat
+ (websocket-encode-frame frame1)
+ (websocket-encode-frame frame2))))
+ (flet ((websocket-process-frame
+ (websocket frame)
+ (lexical-let ((frame frame))
+ (lambda () (push frame processed-frames))))
+ (websocket-verify-response-code (output) t)
+ (websocket-verify-headers (websocket output) t))
+ (websocket-outer-filter fake-ws "Sec-")
+ (should (eq (websocket-ready-state fake-ws) 'connecting))
+ (should-not open-callback-called)
+ (websocket-outer-filter fake-ws "WebSocket-Accept: acceptstring")
+ (should-not open-callback-called)
+ (websocket-outer-filter fake-ws (concat
+ "\r\n\r\n"
+ (substring websocket-frames 0 2)))
+ (should open-callback-called)
+ (websocket-outer-filter fake-ws (substring websocket-frames 2))
+ (should (equal (list frame2 frame1) processed-frames))
+ (should-not (websocket-inflight-input fake-ws)))
+ (flet ((websocket-close (websocket)))
+ (setf (websocket-ready-state fake-ws) 'connecting)
+ (should (eq 500 (cdr (should-error
+ (websocket-outer-filter fake-ws "HTTP/1.1
500\r\n\r\n")
+ :type
'websocket-received-error-http-response)))))))
+
+(ert-deftest websocket-outer-filter-bad-connection ()
+ (let* ((on-open-calledp)
+ (websocket-closed-calledp)
+ (fake-ws (websocket-inner-create
+ :conn t :url t :accept-string t
+ :on-open (lambda (websocket)
+ (setq on-open-calledp t)))))
+ (flet ((websocket-verify-response-code (output) t)
+ (websocket-verify-headers (websocket output) (error "Bad headers!"))
+ (websocket-close (websocket) (setq websocket-closed-calledp t)))
+ (condition-case err
+ (progn (websocket-outer-filter fake-ws "HTTP/1.1 101\r\n\r\n")
+ (error "Should have thrown an error!"))
+ (error
+ (should-not on-open-calledp)
+ (should websocket-closed-calledp))))))
+
+(ert-deftest websocket-send-text ()
+ (flet ((websocket-send (ws frame)
+ (should (equal
+ (websocket-frame-payload frame)
+ "\344\275\240\345\245\275"))))
+ (websocket-send-text nil "你好")))
+
+(ert-deftest websocket-send ()
+ (let ((ws (websocket-inner-create :conn t :url t :accept-string t)))
+ (flet ((websocket-ensure-connected (websocket))
+ (websocket-openp (websocket) t)
+ (process-send-string (conn string)))
+ ;; Just make sure there is no error.
+ (websocket-send ws (make-websocket-frame :opcode 'ping
+ :completep t)))
+ (should-error (websocket-send ws
+ (make-websocket-frame :opcode 'text)))
+ (should-error (websocket-send ws
+ (make-websocket-frame :opcode 'close
+ :payload "bye!"
+ :completep t))
+ :type 'websocket-illegal-frame)
+ (should-error (websocket-send ws
+ (make-websocket-frame :opcode :close))
+ :type 'websocket-illegal-frame)))
+
+(ert-deftest websocket-verify-client-headers ()
+ (let* ((http "HTTP/1.1")
+ (host "Host: authority")
+ (upgrade "Upgrade: websocket")
+ (key (format "Sec-Websocket-Key: %s" "key"))
+ (version "Sec-Websocket-Version: 13")
+ (origin "Origin: origin")
+ (protocol "Sec-Websocket-Protocol: protocol")
+ (extensions1 "Sec-Websocket-Extensions: foo")
+ (extensions2 "Sec-Websocket-Extensions: bar; baz=2")
+ (all-required-headers (list host upgrade key version)))
+ ;; Test that all these headers are necessary
+ (should (equal
+ '(:key "key" :protocols ("protocol") :extensions ("foo" "bar;
baz=2"))
+ (websocket-verify-client-headers
+ (mapconcat 'identity (append (list http "" protocol extensions1
extensions2)
+ all-required-headers) "\r\n"))))
+ (should (websocket-verify-client-headers
+ (mapconcat 'identity
+ (mapcar 'upcase
+ (append (list http "" protocol extensions1
extensions2)
+ all-required-headers)) "\r\n")))
+ (dolist (header all-required-headers)
+ (should-not (websocket-verify-client-headers
+ (mapconcat 'identity (append (list http "")
+ (remove header
all-required-headers))
+ "\r\n"))))
+ (should-not (websocket-verify-client-headers
+ (mapconcat 'identity (append (list "HTTP/1.0" "")
all-required-headers)
+ "\r\n")))))
+
+(ert-deftest websocket-intersect ()
+ (should (equal '(2) (websocket-intersect '(1 2) '(2 3))))
+ (should (equal nil (websocket-intersect '(1 2) '(3 4))))
+ (should (equal '(1 2) (websocket-intersect '(1 2) '(1 2)))))
+
+(ert-deftest websocket-get-server-response ()
+ (let ((ws (websocket-inner-create :conn t :url t :accept-string "key"
+ :protocols '("spa" "spb")
+ :extensions '("sea" "seb"))))
+ (should (equal (concat
+ "HTTP/1.1 101 Switching Protocols\r\n"
+ "Upgrade: websocket\r\n"
+ "Connection: Upgrade\r\n"
+ "Sec-WebSocket-Accept: key\r\n\r\n")
+ (websocket-get-server-response ws nil nil)))
+ (should (string-match "Sec-Websocket-Protocol: spb\r\n"
+ (websocket-get-server-response ws '("spb" "spc")
nil)))
+ (should-not (string-match "Sec-Websocket-Protocol:"
+ (websocket-get-server-response ws '("spc") nil)))
+ (let ((output (websocket-get-server-response ws '("spa" "spb") nil)))
+ (should (string-match "Sec-Websocket-Protocol: spa\r\n" output))
+ (should (string-match "Sec-Websocket-Protocol: spb\r\n" output)))
+ (should (string-match "Sec-Websocket-Extensions: sea"
+ (websocket-get-server-response ws nil '("sea"
"sec"))))
+ (should-not (string-match "Sec-Websocket-Extensions:"
+ (websocket-get-server-response ws nil '("sec"))))
+ (let ((output (websocket-get-server-response ws nil '("sea" "seb"))))
+ (should (string-match "Sec-Websocket-Extensions: sea\r\n" output))
+ (should (string-match "Sec-Websocket-Extensions: seb\r\n" output)))))
+
+(ert-deftest websocket-server-filter ()
+ (let ((on-open-called)
+ (ws (websocket-inner-create :conn t :url t :accept-string "key"
+ :on-open (lambda (ws) (setq on-open-called
t))))
+ (closed)
+ (response)
+ (processed))
+ (flet ((process-send-string (p text) (setq response text))
+ (websocket-close (ws) (setq closed t))
+ (process-get (process sym) ws))
+ ;; Bad request, in two parts
+ (flet ((websocket-verify-client-headers (text) nil))
+ (websocket-server-filter nil "HTTP/1.0 GET /foo \r\n")
+ (should-not closed)
+ (websocket-server-filter nil "\r\n")
+ (should (equal response "HTTP/1.1 400 Bad Request\r\n\r\n"))
+ (should-not (websocket-inflight-input ws)))
+ ;; Good request, followed by packet
+ (setq closed nil
+ response nil)
+ (setf (websocket-inflight-input ws) nil)
+ (flet ((websocket-verify-client-headers (text) t)
+ (websocket-get-server-response (ws protocols extensions)
+ "response")
+ (websocket-process-input-on-open-ws (ws text)
+ (setq processed t)
+ (should
+ (equal text
websocket-test-hello))))
+ (websocket-server-filter nil
+ (concat "\r\n\r\n" websocket-test-hello))
+ (should (equal (websocket-ready-state ws) 'open))
+ (should-not closed)
+ (should (equal response "response"))
+ (should processed)))))
+
+(ert-deftest websocket-complete-server-response-test ()
+ ;; Example taken from RFC
+ (should (equal
+ (concat "HTTP/1.1 101 Switching Protocols\r\n"
+ "Upgrade: websocket\r\n"
+ "Connection: Upgrade\r\n"
+ "Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=\r\n"
+ "Sec-WebSocket-Protocol: chat\r\n\r\n"
+ )
+ (let ((header-info
+ (websocket-verify-client-headers
+ (concat "GET /chat HTTP/1.1\r\n"
+ "Host: server.example.com\r\n"
+ "Upgrade: websocket\r\n"
+ "Connection: Upgrade\r\n"
+ "Sec-WebSocket-Key:
dGhlIHNhbXBsZSBub25jZQ==\r\n"
+ "Origin: http://example.com\r\n";
+ "Sec-WebSocket-Protocol: chat,
superchat\r\n"
+ "Sec-WebSocket-Version: 13\r\n"))))
+ (should header-info)
+ (let ((ws (websocket-inner-create
+ :conn t :url t
+ :accept-string (websocket-calculate-accept
+ (plist-get header-info :key))
+ :protocols '("chat"))))
+ (websocket-get-server-response
+ ws
+ (plist-get header-info :protocols)
+ (plist-get header-info :extension)))))))
+
+(ert-deftest websocket-server-close ()
+ (let ((websocket-server-websockets
+ (list (websocket-inner-create :conn 'conn-a :url t :accept-string t
+ :server-conn 'a
+ :ready-state 'open)
+ (websocket-inner-create :conn 'conn-b :url t :accept-string t
+ :server-conn 'b
+ :ready-state 'open)
+ (websocket-inner-create :conn 'conn-c :url t :accept-string t
+ :server-conn 'b
+ :ready-state 'closed)))
+ (deleted-processes)
+ (closed-websockets))
+ (flet ((delete-process (conn) (add-to-list 'deleted-processes conn))
+ (websocket-close (ws)
+ ;; we always remove on closing in the
+ ;; actual code.
+ (setq websocket-server-websockets
+ (remove ws websocket-server-websockets))
+ (should-not (eq (websocket-ready-state ws)
'closed))
+ (add-to-list 'closed-websockets ws)))
+ (websocket-server-close 'b))
+ (should (equal deleted-processes '(b)))
+ (should (eq 1 (length closed-websockets)))
+ (should (eq 'conn-b (websocket-conn (car closed-websockets))))
+ (should (eq 1 (length websocket-server-websockets)))
+ (should (eq 'conn-a (websocket-conn (car websocket-server-websockets))))))
+
+(ert-deftest websocket-default-error-handler ()
+ (flet ((try-error
+ (callback-type err expected-message)
+ (flet ((display-warning
+ (type message &optional level buffer-name)
+ (should (eq type 'websocket))
+ (should (eq level :error))
+ (should (string= message expected-message))))
+ (websocket-default-error-handler nil
+ callback-type
+ err))))
+ (try-error
+ 'on-message
+ '(end-of-buffer)
+ "in callback `on-message': End of buffer")
+
+ (try-error
+ 'on-close
+ '(wrong-number-of-arguments 1 2)
+ "in callback `on-close': Wrong number of arguments: 1, 2")))
=== added file 'packages/websocket/websocket.el'
--- a/packages/websocket/websocket.el 1970-01-01 00:00:00 +0000
+++ b/packages/websocket/websocket.el 2013-08-01 18:08:23 +0000
@@ -0,0 +1,989 @@
+;;; websocket.el --- Emacs WebSocket client and server
+
+;; Copyright (c) 2010 Andrew Hyatt
+;;
+;; Author: Andrew Hyatt <ahyatt at gmail dot com>
+;; Maintainer: Andrew Hyatt <ahyatt at gmail dot com>
+;; Keywords: Communication, Websocket, Server
+;; Version: 1.01
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301, USA.
+
+;;; Commentary:
+;; This implements RFC 6455, which can be found at
+;; http://tools.ietf.org/html/rfc6455.
+;;
+;; This library contains code to connect emacs as a client to a
+;; websocket server, and for emacs to act as a server for websocket
+;; connections.
+;;
+;; Websockets clients are created by calling `websocket-open', which
+;; returns a `websocket' struct. Users of this library use the
+;; websocket struct, and can call methods `websocket-send-text', which
+;; sends text over the websocket, or `websocket-send', which sends a
+;; `websocket-frame' struct, enabling finer control of what is sent.
+;; A callback is passed to `websocket-open' that will retrieve
+;; websocket frames called from the websocket. Websockets are
+;; eventually closed with `websocket-close'.
+;;
+;; Server functionality is similar. A server is started with
+;; `websocket-server' called with a port and the callbacks to use,
+;; which returns a process. The process can later be closed with
+;; `websocket-server-close'. A `websocket' struct is also created
+;; for every connection, and is exposed through the callbacks.
+
+(require 'bindat)
+(require 'url-parse)
+(eval-when-compile (require 'cl))
+
+;;; Code:
+
+(defstruct (websocket
+ (:constructor nil)
+ (:constructor websocket-inner-create))
+ "A websocket structure.
+This follows the W3C Websocket API, except translated to elisp
+idioms. The API is implemented in both the websocket struct and
+additional methods. Due to how defstruct slots are accessed, all
+API methods are prefixed with \"websocket-\" and take a websocket
+as an argument, so the distrinction between the struct API and
+the additional helper APIs are not visible to the caller.
+
+A websocket struct is created with `websocket-open'.
+
+`ready-state' contains one of 'connecting, 'open, or
+'closed, depending on the state of the websocket.
+
+The W3C API \"bufferedAmount\" call is not currently implemented,
+since there is no elisp API to get the buffered amount from the
+subprocess. There may, in fact, be output data buffered,
+however, when the `on-message' or `on-close' callbacks are
+called.
+
+`on-open', `on-message', `on-close', and `on-error' are described
+in `websocket-open'.
+
+The `negotiated-extensions' slot lists the extensions accepted by
+both the client and server, and `negotiated-protocols' does the
+same for the protocols.
+"
+ ;; API
+ (ready-state 'connecting)
+ client-data
+ on-open
+ on-message
+ on-close
+ on-error
+ negotiated-protocols
+ negotiated-extensions
+ (server-p nil :read-only t)
+
+ ;; Other data - clients should not have to access this.
+ (url (assert nil) :read-only t)
+ (protocols nil :read-only t)
+ (extensions nil :read-only t)
+ (conn (assert nil) :read-only t)
+ ;; Only populated for servers, this is the server connection.
+ server-conn
+ accept-string
+ (inflight-input nil))
+
+(defvar websocket-version "1.01"
+ "Version numbers of this version of websocket.el.")
+
+(defvar websocket-debug nil
+ "Set to true to output debugging info to a per-websocket buffer.
+The buffer is ` *websocket URL debug*' where URL is the
+URL of the connection.")
+
+(defconst websocket-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
+ "The websocket GUID as defined in RFC 6455.
+Do not change unless the RFC changes.")
+
+(defvar websocket-mask-frames t
+ "If true, we mask frames as defined in the spec.
+This is recommended to be true, and some servers will refuse to
+communicate with unmasked clients.")
+
+(defvar websocket-callback-debug-on-error nil
+ "If true, when an error happens in a client callback, invoke the debugger.
+Having this on can cause issues with missing frames if the debugger is
+exited by quitting instead of continuing, so it's best to have this set
+to `nil' unless it is especially needed.")
+
+(defmacro websocket-document-function (function docstring)
+ "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc."
+ (declare (indent defun)
+ (doc-string 2))
+ `(put ',function 'function-documentation ,docstring))
+
+(websocket-document-function websocket-on-open
+ "Accessor for websocket on-open callback.
+See `websocket-open' for details.
+
+\(fn WEBSOCKET)")
+
+(websocket-document-function websocket-on-message
+ "Accessor for websocket on-message callback.
+See `websocket-open' for details.
+
+\(fn WEBSOCKET)")
+
+(websocket-document-function websocket-on-close
+ "Accessor for websocket on-close callback.
+See `websocket-open' for details.
+
+\(fn WEBSOCKET)")
+
+(websocket-document-function websocket-on-error
+ "Accessor for websocket on-error callback.
+See `websocket-open' for details.
+
+\(fn WEBSOCKET)")
+
+(defun websocket-genbytes (nbytes)
+ "Generate NBYTES random bytes."
+ (let ((s (make-string nbytes ?\s)))
+ (dotimes (i nbytes)
+ (aset s i (random 256)))
+ s))
+
+(defun websocket-try-callback (websocket-callback callback-type websocket
+ &rest rest)
+ "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args.
+If an error happens, it is handled according to
+`websocket-callback-debug-on-error'."
+ ;; This looks like it should be able to done more efficiently, but
+ ;; I'm not sure that's the case. We can't do it as a macro, since
+ ;; we want it to change whenever websocket-callback-debug-on-error
+ ;; changes.
+ (let ((args rest)
+ (debug-on-error websocket-callback-debug-on-error))
+ (push websocket args)
+ (if websocket-callback-debug-on-error
+ (condition-case err
+ (apply (funcall websocket-callback websocket) args)
+ ((debug error) (funcall (websocket-on-error websocket)
+ websocket callback-type err)))
+ (condition-case err
+ (apply (funcall websocket-callback websocket) args)
+ (error (funcall (websocket-on-error websocket) websocket
+ callback-type err))))))
+
+(defun websocket-genkey ()
+ "Generate a key suitable for the websocket handshake."
+ (base64-encode-string (websocket-genbytes 16)))
+
+(defun websocket-calculate-accept (key)
+ "Calculate the expect value of the accept header.
+This is based on the KEY from the Sec-WebSocket-Key header."
+ (base64-encode-string
+ (sha1 (concat key websocket-guid) nil nil t)))
+
+(defun websocket-get-bytes (s n)
+ "From string S, retrieve the value of N bytes.
+Return the value as an unsigned integer. The value N must be a
+power of 2, up to 8.
+
+We support getting frames up to 536870911 bytes (2^29 - 1),
+approximately 537M long."
+ (if (= n 8)
+ (let* ((32-bit-parts
+ (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val))
+ (cval
+ (logior (lsh (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1))))
+ (if (and (= (aref 32-bit-parts 0) 0)
+ (= (lsh (aref 32-bit-parts 1) -29) 0))
+ cval
+ (signal 'websocket-unparseable-frame
+ "Frame value found too large to parse!")))
+ ;; n is not 8
+ (bindat-get-field
+ (condition-case err
+ (bindat-unpack
+ `((:val
+ ,(cond ((= n 1) 'u8)
+ ((= n 2) 'u16)
+ ((= n 4) 'u32)
+ ;; This is an error with the library,
+ ;; not a user-facing, meaningful error.
+ (t (error
+ "websocket-get-bytes: Unknown N: %s" n)))))
+ s)
+ (args-out-of-range (signal 'websocket-unparseable-frame
+ (format "Frame unexpectedly shortly: %s"
s))))
+ :val)))
+
+(defun websocket-to-bytes (val nbytes)
+ "Encode the integer VAL in NBYTES of data.
+NBYTES much be a power of 2, up to 8.
+
+This supports encoding values up to 536870911 bytes (2^29 - 1),
+approximately 537M long."
+ (when (and (< nbytes 8)
+ (> val (expt 2 (* 8 nbytes))))
+ ;; not a user-facing error, this must be caused from an error in
+ ;; this library
+ (error "websocket-to-bytes: Value %d could not be expressed in %d bytes"
+ val nbytes))
+ (if (= nbytes 8)
+ (progn
+ (let ((hi-32bits (lsh val -32))
+ (low-32bits (logand #xffffffff val)))
+ (when (or (> hi-32bits 0) (> (lsh low-32bits -29) 0))
+ (signal 'websocket-frame-too-large val))
+ (bindat-pack `((:val vec 2 u32))
+ `((:val . [,hi-32bits ,low-32bits])))))
+ (bindat-pack
+ `((:val ,(cond ((= nbytes 1) 'u8)
+ ((= nbytes 2) 'u16)
+ ((= nbytes 4) 'u32)
+ ;; Library error, not system error
+ (t (error "websocket-to-bytes: Unknown NBYTES: %s"
nbytes)))))
+ `((:val . ,val)))))
+
+(defun websocket-get-opcode (s)
+ "Retrieve the opcode from first byte of string S."
+ (websocket-ensure-length s 1)
+ (let ((opcode (logand #xf (websocket-get-bytes s 1))))
+ (cond ((= opcode 0) 'continuation)
+ ((= opcode 1) 'text)
+ ((= opcode 2) 'binary)
+ ((= opcode 8) 'close)
+ ((= opcode 9) 'ping)
+ ((= opcode 10) 'pong))))
+
+(defun websocket-get-payload-len (s)
+ "Parse out the payload length from the string S.
+We start at position 0, and return a cons of the payload length and how
+many bytes were consumed from the string."
+ (websocket-ensure-length s 1)
+ (let* ((initial-val (logand 127 (websocket-get-bytes s 1))))
+ (cond ((= initial-val 127)
+ (websocket-ensure-length s 9)
+ (cons (websocket-get-bytes (substring s 1) 8) 9))
+ ((= initial-val 126)
+ (websocket-ensure-length s 3)
+ (cons (websocket-get-bytes (substring s 1) 2) 3))
+ (t (cons initial-val 1)))))
+
+(defstruct websocket-frame opcode payload length completep)
+
+(defun websocket-mask (key data)
+ "Using string KEY, mask string DATA according to the RFC.
+This is used to both mask and unmask data."
+ (apply
+ 'string
+ (loop for b across data
+ for i from 0 to (length data)
+ collect (logxor (websocket-get-bytes (substring key (mod i 4)) 1)
b))))
+
+(defun websocket-ensure-length (s n)
+ "Ensure the string S has at most N bytes.
+Otherwise we throw the error `websocket-incomplete-frame'."
+ (when (< (length s) n)
+ (throw 'websocket-incomplete-frame nil)))
+
+(defun websocket-encode-frame (frame)
+ "Encode the FRAME struct to the binary representation."
+ (let* ((opcode (websocket-frame-opcode frame))
+ (payload (websocket-frame-payload frame))
+ (fin (websocket-frame-completep frame))
+ (payloadp (memq opcode '(continuation text binary)))
+ (mask-key (when websocket-mask-frames (websocket-genbytes 4))))
+ (apply 'unibyte-string
+ (append (list
+ (logior (cond ((eq opcode 'continuation) 0)
+ ((eq opcode 'text) 1)
+ ((eq opcode 'binary) 2)
+ ((eq opcode 'close) 8)
+ ((eq opcode 'ping) 9)
+ ((eq opcode 'pong) 10))
+ (if fin 128 0)))
+ (when payloadp
+ (list
+ (logior
+ (if websocket-mask-frames 128 0)
+ (cond ((< (length payload) 126) (length payload))
+ ((< (length payload) 65536) 126)
+ (t 127)))))
+ (when (and payloadp (>= (length payload) 126))
+ (append (websocket-to-bytes (length payload)
+ (cond ((< (length payload) 126) 1)
+ ((< (length payload) 65536) 2)
+ (t 8))) nil))
+ (when (and payloadp websocket-mask-frames)
+ (append mask-key nil))
+ (when payloadp
+ (append (if websocket-mask-frames
+ (websocket-mask mask-key payload)
+ payload)
+ nil))))))
+
+(defun websocket-read-frame (s)
+ "Read from string S a `websocket-frame' struct with the contents.
+This only gets complete frames. Partial frames need to wait until
+the frame finishes. If the frame is not completed, return NIL."
+ (catch 'websocket-incomplete-frame
+ (websocket-ensure-length s 1)
+ (let* ((opcode (websocket-get-opcode s))
+ (fin (logand 128 (websocket-get-bytes s 1)))
+ (payloadp (memq opcode '(continuation text binary)))
+ (payload-len (when payloadp
+ (websocket-get-payload-len (substring s 1))))
+ (maskp (and
+ payloadp
+ (= 128 (logand 128 (websocket-get-bytes (substring s 1)
1)))))
+ (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len))))
+ (payload-end (when payloadp (+ payload-start (car payload-len))))
+ (unmasked-payload (when payloadp
+ (websocket-ensure-length s payload-end)
+ (substring s payload-start payload-end))))
+ (make-websocket-frame
+ :opcode opcode
+ :payload
+ (if maskp
+ (let ((masking-key (substring s (+ 1 (cdr payload-len))
+ (+ 5 (cdr payload-len)))))
+ (websocket-mask masking-key unmasked-payload))
+ unmasked-payload)
+ :length (if payloadp payload-end 1)
+ :completep (> fin 0)))))
+
+(defun websocket-format-error (err)
+ "Format an error message like command level does. ERR should be
+a cons of error symbol and error data."
+
+ ;; Formatting code adapted from `edebug-report-error'
+ (concat (or (get (car err) 'error-message)
+ (format "peculiar error (%s)" (car err)))
+ (when (cdr err)
+ (format ": %s"
+ (mapconcat #'prin1-to-string
+ (cdr err) ", ")))))
+
+(defun websocket-default-error-handler (websocket type err)
+ "The default error handler used to handle errors in callbacks."
+ (display-warning 'websocket
+ (format "in callback `%S': %s"
+ type
+ (websocket-format-error err))
+ :error))
+
+;; Error symbols in use by the library
+(put 'websocket-unsupported-protocol 'error-conditions
+ '(error websocket-error websocket-unsupported-protocol))
+(put 'websocket-unsupported-protocol 'error-message "Unsupported websocket
protocol")
+(put 'websocket-wss-needs-emacs-24 'error-conditions
+ '(error websocket-error websocket-unsupported-protocol
+ websocket-wss-needs-emacs-24))
+(put 'websocket-wss-needs-emacs-24 'error-message
+ "wss protocol is not supported for Emacs before version 24.")
+(put 'websocket-received-error-http-response 'error-conditions
+ '(error websocket-error websocket-received-error-http-response))
+(put 'websocket-received-error-http-response 'error-message
+ "Error response received from websocket server")
+(put 'websocket-invalid-header 'error-conditions
+ '(error websocket-error websocket-invalid-header))
+(put 'websocket-invalid-header 'error-message
+ "Invalid HTTP header sent")
+(put 'websocket-illegal-frame 'error-conditions
+ '(error websocket-error websocket-illegal-frame))
+(put 'websocket-illegal-frame 'error-message
+ "Cannot send illegal frame to websocket")
+(put 'websocket-closed 'error-conditions
+ '(error websocket-error websocket-closed))
+(put 'websocket-closed 'error-message
+ "Cannot send message to a closed websocket")
+(put 'websocket-unparseable-frame 'error-conditions
+ '(error websocket-error websocket-unparseable-frame))
+(put 'websocket-unparseable-frame 'error-message
+ "Received an unparseable frame")
+(put 'websocket-frame-too-large 'error-conditions
+ '(error websocket-error websocket-frame-too-large))
+(put 'websocket-frame-too-large 'error-message
+ "The frame being sent is too large for this emacs to handle")
+
+(defun websocket-intersect (a b)
+ "Simple list intersection, should function like common lisp's
`intersection'."
+ (let ((result))
+ (dolist (elem a (nreverse result))
+ (when (member elem b)
+ (add-to-list 'result elem)))))
+
+(defun websocket-get-debug-buffer-create (websocket)
+ "Get or create the buffer corresponding to WEBSOCKET."
+ (let ((buf (get-buffer-create (format "*websocket %s debug*"
+ (websocket-url websocket)))))
+ (when (= 0 (buffer-size buf))
+ (buffer-disable-undo buf))
+ buf))
+
+(defun websocket-debug (websocket msg &rest args)
+ "In the WEBSOCKET's debug buffer, send MSG, with format ARGS."
+ (when websocket-debug
+ (let ((buf (websocket-get-debug-buffer-create websocket)))
+ (save-excursion
+ (with-current-buffer buf
+ (goto-char (point-max))
+ (insert "[WS] ")
+ (insert (apply 'format (append (list msg) args)))
+ (insert "\n"))))))
+
+(defun websocket-verify-response-code (output)
+ "Verify that OUTPUT contains a valid HTTP response code.
+The only acceptable one to websocket is responce code 101.
+A t value will be returned on success, and an error thrown
+if not."
+ (string-match "HTTP/1.1 \\([[:digit:]]+\\)" output)
+ (unless (equal "101" (match-string 1 output))
+ (signal 'websocket-received-error-http-response
+ (string-to-number (match-string 1 output))))
+ t)
+
+(defun websocket-parse-repeated-field (output field)
+ "From header-containing OUTPUT, parse out the list from a
+possibly repeated field."
+ (let ((pos 0)
+ (extensions))
+ (while (and pos
+ (string-match (format "\r\n%s: \\(.*\\)\r\n" field)
+ output pos))
+ (when (setq pos (match-end 1))
+ (setq extensions (append extensions (split-string
+ (match-string 1 output) ", ?")))))
+ extensions))
+
+(defun websocket-process-frame (websocket frame)
+ "Using the WEBSOCKET's filter and connection, process the FRAME.
+This returns a lambda that should be executed when all frames have
+been processed. If the frame has a payload, the lambda has the frame
+passed to the filter slot of WEBSOCKET. If the frame is a ping,
+the lambda has a reply with a pong. If the frame is a close, the lambda
+has connection termination."
+ (let ((opcode (websocket-frame-opcode frame)))
+ (lexical-let ((lex-ws websocket)
+ (lex-frame frame))
+ (cond ((memq opcode '(continuation text binary))
+ (lambda () (websocket-try-callback 'websocket-on-message
'on-message
+ lex-ws lex-frame)))
+ ((eq opcode 'ping)
+ (lambda () (websocket-send lex-ws
+ (make-websocket-frame :opcode 'pong
:completep t))))
+ ((eq opcode 'close)
+ (lambda () (delete-process (websocket-conn lex-ws))))
+ (t (lambda ()))))))
+
+(defun websocket-process-input-on-open-ws (websocket text)
+ "This handles input processing for both the client and server filters."
+ (let ((current-frame)
+ (processing-queue)
+ (start-point 0))
+ (while (setq current-frame (websocket-read-frame
+ (substring text start-point)))
+ (push (websocket-process-frame websocket current-frame) processing-queue)
+ (incf start-point (websocket-frame-length current-frame)))
+ (when (> (length text) start-point)
+ (setf (websocket-inflight-input websocket)
+ (substring text start-point)))
+ (dolist (to-process (nreverse processing-queue))
+ (funcall to-process))))
+
+(defun websocket-send-text (websocket text)
+ "To the WEBSOCKET, send TEXT as a complete frame."
+ (websocket-send
+ websocket
+ (make-websocket-frame :opcode 'text
+ :payload (encode-coding-string
+ text 'raw-text)
+ :completep t)))
+
+(defun websocket-check (frame)
+ "Check FRAME for correctness, returning true if correct."
+ (and (equal (not (memq (websocket-frame-opcode frame)
+ '(continuation text binary)))
+ (and (not (websocket-frame-payload frame))
+ (websocket-frame-completep frame)))))
+
+(defun websocket-send (websocket frame)
+ "To the WEBSOCKET server, send the FRAME.
+This will raise an error if the frame is illegal.
+
+The error signaled may be of type `websocket-illegal-frame' if
+the frame is malformed in some way, also having the condition
+type of `websocket-error'. The data associated with the signal
+is the frame being sent.
+
+If the websocket is closed a signal `websocket-closed' is sent,
+also with `websocket-error' condition. The data in the signal is
+also the frame.
+
+The frame may be too large for this buid of emacs, in which case
+`websocket-frame-too-large' is returned, with the data of the
+size of the frame which was too large to process. This also has
+the `websocket-error' condition."
+ (unless (websocket-check frame)
+ (signal 'websocket-illegal-frame frame))
+ (websocket-debug websocket "Sending frame, opcode: %s payload: %s"
+ (websocket-frame-opcode frame)
+ (websocket-frame-payload frame))
+ (websocket-ensure-connected websocket)
+ (unless (websocket-openp websocket)
+ (signal 'websocket-closed frame))
+ (process-send-string (websocket-conn websocket)
+ (websocket-encode-frame frame)))
+
+(defun websocket-openp (websocket)
+ "Check WEBSOCKET and return non-nil if it is open, and either
+connecting or open."
+ (and websocket
+ (not (eq 'close (websocket-ready-state websocket)))
+ (member (process-status (websocket-conn websocket)) '(open run))))
+
+(defun websocket-close (websocket)
+ "Close WEBSOCKET and erase all the old websocket data."
+ (websocket-debug websocket "Closing websocket")
+ (when (websocket-openp websocket)
+ (websocket-send websocket
+ (make-websocket-frame :opcode 'close
+ :completep t))
+ (setf (websocket-ready-state websocket) 'closed))
+ (let ((buf (process-buffer (websocket-conn websocket))))
+ (delete-process (websocket-conn websocket))
+ (kill-buffer buf)))
+
+(defun websocket-ensure-connected (websocket)
+ "If the WEBSOCKET connection is closed, open it."
+ (unless (and (websocket-conn websocket)
+ (ecase (process-status (websocket-conn websocket))
+ ((run open listen) t)
+ ((stop exit signal closed connect failed nil) nil)))
+ (websocket-close websocket)
+ (websocket-open (websocket-url websocket)
+ :protocols (websocket-protocols websocket)
+ :extensions (websocket-extensions websocket)
+ :on-open (websocket-on-open websocket)
+ :on-message (websocket-on-message websocket)
+ :on-close (websocket-on-close websocket)
+ :on-error (websocket-on-error websocket))))
+
+;;;;;;;;;;;;;;;;;;;;;;
+;; Websocket client ;;
+;;;;;;;;;;;;;;;;;;;;;;
+
+(defun* websocket-open (url &key protocols extensions (on-open 'identity)
+ (on-message (lambda (w f))) (on-close 'identity)
+ (on-error 'websocket-default-error-handler))
+ "Open a websocket connection to URL, returning the `websocket' struct.
+The PROTOCOL argument is optional, and setting it will declare to
+the server that this client supports the protocols in the list
+given. We will require that the server also has to support that
+protocols.
+
+Similar logic applies to EXTENSIONS, which is a list of conses,
+the car of which is a string naming the extension, and the cdr of
+which is the list of parameter strings to use for that extension.
+The parameter strings are of the form \"key=value\" or \"value\".
+EXTENSIONS can be NIL if none are in use. An example value would
+be '(\"deflate-stream\" . (\"mux\" \"max-channels=4\")).
+
+Optionally you can specify
+ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well.
+
+The ON-OPEN callback is called after the connection is
+established with the websocket as the only argument. The return
+value is unused.
+
+The ON-MESSAGE callback is called after receiving a frame, and is
+called with the websocket as the first argument and
+`websocket-frame' struct as the second. The return value is
+unused.
+
+The ON-CLOSE callback is called after the connection is closed, or
+failed to open. It is called with the websocket as the only
+argument, and the return value is unused.
+
+The ON-ERROR callback is called when any of the other callbacks
+have an error. It takes the websocket as the first argument, and
+a symbol as the second argument either `on-open', `on-message',
+or `on-close', and the error as the third argument. Do NOT
+rethrow the error, or else you may miss some websocket messages.
+You similarly must not generate any other errors in this method.
+If you want to debug errors, set
+`websocket-callback-debug-on-error' to `t', but this also can be
+dangerous is the debugger is quit out of. If not specified,
+`websocket-default-error-handler' is used.
+
+For each of these event handlers, the client code can store
+arbitrary data in the `client-data' slot in the returned
+websocket.
+
+The following errors might be thrown in this method or in
+websocket processing, all of them having the error-condition
+`websocket-error' in addition to their own symbol:
+
+`websocket-unsupported-protocol': Data in the error signal is the
+protocol that is unsupported. For example, giving a URL starting
+with http by mistake raises this error.
+
+`websocket-wss-needs-emacs-24': Trying to connect wss protocol
+using Emacs < 24 raises this error. You can catch this error
+also by `websocket-unsupported-protocol'.
+
+`websocket-received-error-http-response': Data in the error
+signal is the integer error number.
+
+`websocket-invalid-header': Data in the error is a string
+describing the invalid header received from the server.
+
+`websocket-unparseable-frame': Data in the error is a string
+describing the problem with the frame.
+"
+ (let* ((name (format "websocket to %s" url))
+ (url-struct (url-generic-parse-url url))
+ (key (websocket-genkey))
+ (buf-name (format " *%s*" name))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (conn (if (member (url-type url-struct) '("ws" "wss"))
+ (let* ((type (if (equal (url-type url-struct) "ws")
+ 'plain 'tls))
+ (port (if (= 0 (url-port url-struct))
+ (if (eq type 'tls) 443 80)
+ (url-port url-struct)))
+ (host (url-host url-struct))
+ (buf (get-buffer-create buf-name)))
+ (if (eq type 'plain)
+ (make-network-process :name name :buffer buf :host
host
+ :service port :nowait nil)
+ (condition-case-unless-debug nil
+ (open-network-stream name buf host port :type
type :nowait nil)
+ (wrong-number-of-arguments
+ (signal 'websocket-wss-needs-emacs-24 "wss")))))
+ (signal 'websocket-unsupported-protocol (url-type
url-struct))))
+ (websocket (websocket-inner-create
+ :conn conn
+ :url url
+ :on-open on-open
+ :on-message on-message
+ :on-close on-close
+ :on-error on-error
+ :protocols protocols
+ :extensions (mapcar 'car extensions)
+ :accept-string
+ (websocket-calculate-accept key))))
+ (process-put conn :websocket websocket)
+ (set-process-filter conn
+ (lambda (process output)
+ (let ((websocket (process-get process :websocket)))
+ (websocket-outer-filter websocket output))))
+ (set-process-sentinel
+ conn
+ (lambda (process change)
+ (let ((websocket (process-get process :websocket)))
+ (websocket-debug websocket
+ "State change to %s" change)
+ (unless (eq 'closed (websocket-ready-state websocket))
+ (websocket-try-callback 'websocket-on-close 'on-close websocket)))))
+ (set-process-query-on-exit-flag conn nil)
+ (process-send-string conn
+ (format "GET %s HTTP/1.1\r\n"
+ (let ((path (url-filename url-struct)))
+ (if (> (length path) 0) path "/"))))
+ (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s"
+ key (websocket-accept-string websocket))
+ (process-send-string conn
+ (websocket-create-headers url key protocols
extensions))
+ (websocket-debug websocket "Websocket opened")
+ websocket))
+
+(defun websocket-outer-filter (websocket output)
+ "Filter the WEBSOCKET server's OUTPUT.
+This will parse headers and process frames repeatedly until there
+is no more output or the connection closes. If the websocket
+connection is invalid, the connection will be closed."
+ (websocket-debug websocket "Received: %s" output)
+ (let ((start-point)
+ (end-point 0)
+ (text (concat (websocket-inflight-input websocket) output))
+ (header-end-pos))
+ (setf (websocket-inflight-input websocket) nil)
+ ;; If we've received the complete header, check to see if we've
+ ;; received the desired handshake.
+ (when (and (eq 'connecting (websocket-ready-state websocket))
+ (setq header-end-pos (string-match "\r\n\r\n" text))
+ (setq start-point (+ 4 header-end-pos)))
+ (condition-case err
+ (progn
+ (websocket-verify-response-code text)
+ (websocket-verify-headers websocket text))
+ (error
+ (websocket-close websocket)
+ (signal (car err) (cdr err))))
+ (setf (websocket-ready-state websocket) 'open)
+ (websocket-try-callback 'websocket-on-open 'on-open websocket))
+ (when (eq 'open (websocket-ready-state websocket))
+ (websocket-process-input-on-open-ws
+ websocket (substring text (or start-point 0))))))
+
+(defun websocket-verify-headers (websocket output)
+ "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid.
+The output is assumed to have complete headers. This function
+will either return t or call `error'. This has the side-effect
+of populating the list of server extensions to WEBSOCKET."
+ (let ((accept-string
+ (concat "Sec-WebSocket-Accept: " (websocket-accept-string
websocket))))
+ (websocket-debug websocket "Checking for accept header: %s" accept-string)
+ (unless (string-match (regexp-quote accept-string) output)
+ (signal 'websocket-invalid-header
+ "Incorrect handshake from websocket: is this really a websocket
connection?")))
+ (let ((case-fold-search t))
+ (websocket-debug websocket "Checking for upgrade header")
+ (unless (string-match "\r\nUpgrade: websocket\r\n" output)
+ (signal 'websocket-invalid-header
+ "No 'Upgrade: websocket' header found"))
+ (websocket-debug websocket "Checking for connection header")
+ (unless (string-match "\r\nConnection: upgrade\r\n" output)
+ (signal 'websocket-invalid-header
+ "No 'Connection: upgrade' header found"))
+ (when (websocket-protocols websocket)
+ (dolist (protocol (websocket-protocols websocket))
+ (websocket-debug websocket "Checking for protocol match: %s"
+ protocol)
+ (let ((protocols))
+ (if (string-match
+ (format "\r\nSec-Websocket-Protocol: %s\r\n"
+ protocol) output)
+ (add-to-list 'protocols protocol)
+ (signal 'websocket-invalid-header
+ "Incorrect or missing protocol returned by the server."))
+ (setf (websocket-negotiated-protocols websocket) protocols))))
+ (let* ((extensions (websocket-parse-repeated-field
+ output
+ "Sec-WebSocket-Extensions"))
+ (extra-extensions))
+ (dolist (ext extensions)
+ (when (not (member
+ (first (split-string ext "; ?"))
+ (websocket-extensions websocket)))
+ (add-to-list 'extra-extensions (first (split-string ext "; ?")))))
+ (when extra-extensions
+ (signal 'websocket-invalid-header
+ (format "Non-requested extensions returned by server: %S"
+ extra-extensions)))
+ (setf (websocket-negotiated-extensions websocket) extensions)))
+ t)
+
+;;;;;;;;;;;;;;;;;;;;;;
+;; Websocket server ;;
+;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar websocket-server-websockets nil
+ "A list of current websockets live on any server.")
+
+(defun* websocket-server (port &rest plist)
+ "Open a websocket server on PORT.
+This also takes a plist of callbacks: `:on-open', `:on-message',
+`:on-close' and `:on-error', which operate exactly as documented
+in the websocket client function `websocket-open'. Returns the
+connection, which should be kept in order to pass to
+`websocket-server-close'."
+ (let* ((conn (make-network-process
+ :name (format "websocket server on port %d" port)
+ :server t
+ :family 'ipv4
+ :log 'websocket-server-accept
+ :filter-multibyte nil
+ :plist plist
+ :service port)))
+ conn))
+
+(defun websocket-server-close (conn)
+ "Closes the websocket, as well as all open websockets for this server."
+ (let ((to-delete))
+ (dolist (ws websocket-server-websockets)
+ (when (eq (websocket-server-conn ws) conn)
+ (if (eq (websocket-ready-state ws) 'closed)
+ (add-to-list 'to-delete ws)
+ (websocket-close ws))))
+ (dolist (ws to-delete)
+ (setq websocket-server-websockets (remove ws
websocket-server-websockets))))
+ (delete-process conn))
+
+(defun websocket-server-accept (server client message)
+ "Accept a new websocket connection from a client."
+ (let ((ws (websocket-inner-create
+ :server-conn server
+ :conn client
+ :url client
+ :on-open (or (process-get server :on-open) 'identity)
+ :on-message (or (process-get server :on-message) (lambda (ws
frame)))
+ :on-close (lexical-let ((user-method
+ (or (process-get server :on-close)
'identity)))
+ (lambda (ws)
+ (setq websocket-server-websockets
+ (remove ws websocket-server-websockets))
+ (funcall user-method ws)))
+ :on-error (or (process-get server :on-error)
+ 'websocket-default-error-handler)
+ :protocols (process-get server :protocol)
+ :extensions (mapcar 'car (process-get server :extensions)))))
+ (add-to-list 'websocket-server-websockets ws)
+ (set-process-coding-system client 'unix 'unix)
+ (process-put client :websocket ws)
+ (set-process-filter client 'websocket-server-filter)
+ (set-process-coding-system client 'binary)
+ (set-process-sentinel client
+ (lambda (process change)
+ (let ((websocket (process-get process :websocket)))
+ (websocket-debug websocket "State change to %s" change)
+ (unless (eq 'closed (websocket-ready-state websocket))
+ (websocket-try-callback 'websocket-on-close 'on-close
websocket)))))))
+
+(defun websocket-create-headers (url key protocol extensions)
+ "Create connections headers for the given URL, KEY, PROTOCOL and EXTENSIONS.
+These are defined as in `websocket-open'."
+ (format (concat "Host: %s\r\n"
+ "Upgrade: websocket\r\n"
+ "Connection: Upgrade\r\n"
+ "Sec-WebSocket-Key: %s\r\n"
+ "Origin: %s\r\n"
+ "Sec-WebSocket-Version: 13\r\n"
+ (when protocol
+ (concat
+ (mapconcat (lambda (protocol)
+ (format "Sec-WebSocket-Protocol: %s"
protocol))
+ protocol "\r\n")
+ "\r\n"))
+ (when extensions
+ (format "Sec-WebSocket-Extensions: %s\r\n"
+ (mapconcat
+ (lambda (ext)
+ (concat (car ext)
+ (when (cdr ext) "; ")
+ (when (cdr ext)
+ (mapconcat 'identity (cdr ext) ";
"))))
+ extensions ", ")))
+ "\r\n")
+ (url-host (url-generic-parse-url url))
+ key
+ system-name
+ protocol))
+
+(defun websocket-get-server-response (websocket client-protocols
client-extensions)
+ "Get the websocket response from client WEBSOCKET."
+ (let ((separator "\r\n"))
+ (concat "HTTP/1.1 101 Switching Protocols" separator
+ "Upgrade: websocket" separator
+ "Connection: Upgrade" separator
+ "Sec-WebSocket-Accept: "
+ (websocket-accept-string websocket) separator
+ (let ((protocols
+ (websocket-intersect client-protocols
+ (websocket-protocols
websocket))))
+ (when protocols
+ (concat
+ (mapconcat
+ (lambda (protocol) (format "Sec-WebSocket-Protocol: %s"
+ protocol)) protocols separator)
+ separator)))
+ (let ((extensions (websocket-intersect
+ client-extensions
+ (websocket-extensions websocket))))
+ (when extensions
+ (concat
+ (mapconcat
+ (lambda (extension) (format "Sec-Websocket-Extensions:
%s"
+ extension)) extensions separator)
+ separator)))
+ separator)))
+
+(defun websocket-server-filter (process output)
+ "This acts on all OUTPUT from websocket clients PROCESS."
+ (let* ((ws (process-get process :websocket))
+ (text (concat (websocket-inflight-input ws) output)))
+ (setf (websocket-inflight-input ws) nil)
+ (cond ((eq (websocket-ready-state ws) 'connecting)
+ ;; check for connection string
+ (let ((end-of-header-pos
+ (let ((pos (string-match "\r\n\r\n" text)))
+ (when pos (+ 4 pos)))))
+ (if end-of-header-pos
+ (progn
+ (let ((header-info (websocket-verify-client-headers
text)))
+ (if header-info
+ (progn (setf (websocket-accept-string ws)
+ (websocket-calculate-accept
+ (plist-get header-info :key)))
+ (process-send-string
+ process
+ (websocket-get-server-response
+ ws (plist-get header-info :protocols)
+ (plist-get header-info :extensions)))
+ (setf (websocket-ready-state ws) 'open)
+ (websocket-try-callback 'websocket-on-open
+ 'on-open ws))
+ (message "Invalid client headers found in: %s" output)
+ (process-send-string process "HTTP/1.1 400 Bad
Request\r\n\r\n")
+ (websocket-close ws)))
+ (when (> (length text) (+ 1 end-of-header-pos))
+ (websocket-server-filter process (substring
+ text
+
end-of-header-pos))))
+ (setf (websocket-inflight-input ws) text))))
+ ((eq (websocket-ready-state ws) 'open)
+ (websocket-process-input-on-open-ws ws text))
+ ((eq (websocket-ready-state ws) 'closed)
+ (message "WARNING: Should not have received further input on closed
websocket")))))
+
+(defun websocket-verify-client-headers (output)
+ "Verify the headers from the WEBSOCKET client connection in OUTPUT.
+Unlike `websocket-verify-headers', this is a quieter routine. We
+don't want to error due to a bad client, so we just print out
+messages and a plist containing `:key', the websocket key,
+`:protocols' and `:extensions'."
+ (block nil
+ (let ((case-fold-search t)
+ (plist))
+ (unless (string-match "HTTP/1.1" output)
+ (message "Websocket client connection: HTTP/1.1 not found")
+ (return nil))
+ (unless (string-match "^Host: " output)
+ (message "Websocket client connection: Host header not found")
+ (return nil))
+ (unless (string-match "^Upgrade: websocket\r\n" output)
+ (message "Websocket client connection: Upgrade: websocket not found")
+ (return nil))
+ (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output)
+ (setq plist (plist-put plist :key (match-string 1 output)))
+ (message "Websocket client connect: No key sent")
+ (return nil))
+ (unless (string-match "^Sec-WebSocket-Version: 13" output)
+ (message "Websocket client connect: Websocket version 13 not found")
+ (return nil))
+ (when (string-match "^Sec-WebSocket-Protocol:" output)
+ (setq plist (plist-put plist :protocols (websocket-parse-repeated-field
+ output
+ "Sec-Websocket-Protocol"))))
+ (when (string-match "^Sec-WebSocket-Extensions:" output)
+ (setq plist (plist-put plist :extensions
(websocket-parse-repeated-field
+ output
+
"Sec-Websocket-Extensions"))))
+ plist)))
+
+(provide 'websocket)
+
+;;; websocket.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [ELPA-diffs] elpa r429: Add websocket git revno bc5c2a2ee2b993a18e8e23ed725829d403508753.,
Stefan Monnier <=