From e42a64fd0e8dc35f044f16cd7b732f715985cb2c Mon Sep 17 00:00:00 2001 From: John Miller Date: Sat, 24 Sep 2016 12:59:20 -0500 Subject: [PATCH] Squashed 'lib/websocket/' content from commit 5675553 git-subtree-dir: lib/websocket git-subtree-split: 567555360443f5de0a6426c5e2d88ba037c33855 --- COPYING | 339 +++++++++++ README.org | 32 ++ testserver.py | 34 ++ websocket-functional-test.el | 158 ++++++ websocket-test.el | 675 ++++++++++++++++++++++ websocket.el | 1034 ++++++++++++++++++++++++++++++++++ 6 files changed, 2272 insertions(+) create mode 100644 COPYING create mode 100644 README.org create mode 100644 testserver.py create mode 100644 websocket-functional-test.el create mode 100644 websocket-test.el create mode 100644 websocket.el diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..ecbc059 --- /dev/null +++ b/COPYING @@ -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. + + + Copyright (C) + + 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. + + , 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 diff --git a/README.org b/README.org new file mode 100644 index 0000000..b7fb0a1 --- /dev/null +++ b/README.org @@ -0,0 +1,32 @@ +* 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]] +- [[https://github.com/ancane/markdown-preview-mode][Markdown-preview-mode]] + +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. + diff --git a/testserver.py b/testserver.py new file mode 100644 index 0000000..e75d1d4 --- /dev/null +++ b/testserver.py @@ -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, "127.0.0.1") + logging.info("STARTED: Server start listening") + ioloop.IOLoop.instance().start() diff --git a/websocket-functional-test.el b/websocket-functional-test.el new file mode 100644 index 0000000..e447015 --- /dev/null +++ b/websocket-functional-test.el @@ -0,0 +1,158 @@ +;;; websocket-functional-test.el --- Simple functional testing + +;; Copyright (c) 2013, 2016 Free Software Foundation, Inc. + +;; 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 3 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 GNU Emacs. If not, see . + +;;; Commentary: + +;; 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))) + +(if (not (eq system-type 'windows-nt)) + ; Windows doesn't have support for the SIGSTP signal, so we'll just kill + ; the process. + (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-number (substring emacs-version 0 2)) 24) + (message "Testing with wss://echo.websocket.org") + (when (eq system-type 'windows-nt) + (message "Windows users must have gnutls DLLs in the emacs bin directory.")) + (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 (eq 'open (websocket-ready-state wstest-ws))) + (assert (null wstest-msgs)) + (websocket-send-text wstest-ws "Hi!") + (sleep-for 1) + (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) +(let ((server-conn (websocket-server + 9998 + :host 'local + :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") diff --git a/websocket-test.el b/websocket-test.el new file mode 100644 index 0000000..ab6740d --- /dev/null +++ b/websocket-test.el @@ -0,0 +1,675 @@ +;;; websocket-test.el --- Unit tests for the websocket layer + +;; Copyright (c) 2013 Free Software Foundation, Inc. +;; +;; Author: Andrew Hyatt +;; Maintainer: Andrew Hyatt +;; +;; 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 3 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 GNU Emacs. If not, see . + +;;; 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"))))) + (should-error (websocket-verify-response-code "HTTP/1.") + :type 'websocket-invalid-header)) + +(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 ((base-headers (concat "Host: www.example.com\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: key\r\n" + "Sec-WebSocket-Version: 13\r\n"))) + (flet ((url-cookie-generate-header-lines + (host localpart secure) "")) + (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")))))) + (flet ((url-cookie-generate-header-lines + (host localpart secure) + (should (equal host "www.example.com:123")) + (should (equal localpart "/path")) + (should secure) + "Cookie: foo=bar\r\n")) + (should (equal (websocket-create-headers "wss://www.example.com:123/path" + "key" nil nil) + (concat + "Host: www.example.com:123\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: key\r\n" + "Sec-WebSocket-Version: 13\r\n" + "Cookie: foo=bar\r\n\r\n")))) + (should + (string-match + "Host: www.example.com:123\r\n" + (websocket-create-headers "ws://www.example.com:123/path" "key" nil nil))))) + +(ert-deftest websocket-process-headers () + (flet ((url-cookie-handle-set-cookie + (text) + (should (equal text "foo=bar;")) + ;; test that we have set the implicit buffer variable needed + ;; by url-cookie-handle-set-cookie + (should (equal url-current-object + (url-generic-parse-url "ws://example.com/path"))))) + (websocket-process-headers "ws://example.com/path" + (concat + "HTTP/1.1 101 Switching Protocols\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Set-Cookie: foo=bar;\r\n\r\n"))) + (flet ((url-cookie-handle-set-cookie (text) (should nil))) + (websocket-process-headers "ws://example.com/path" + "HTTP/1.1 101 Switching Protocols\r\n"))) + +(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 :payload "data" :completep t) + (progn + (funcall (websocket-process-frame websocket + (make-websocket-frame :opcode 'ping + :payload "data"))) + 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. + (should (equal + websocket-test-hello + (websocket-encode-frame + (make-websocket-frame :opcode 'text :payload "Hello" :completep t) nil))) + (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) 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) t)))) + (should-not + (websocket-frame-completep + (websocket-read-frame + (websocket-encode-frame (make-websocket-frame :opcode 'text + :payload "Hello" + :completep nil) t)))) + (should (equal 'close (websocket-frame-opcode + (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode 'close :completep t) t))))) + (dolist (opcode '(ping pong)) + (let ((read-frame (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode opcode + :payload "data" + :completep t) t)))) + (should read-frame) + (should (equal + opcode + (websocket-frame-opcode read-frame))) + (should (equal + "data" (websocket-frame-payload read-frame))))) + ;; A frame should be four bytes, even for no-data pings. + (should (equal 2 (websocket-frame-length + (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode 'ping :completep t) t)))))) + +(ert-deftest websocket-check () + (should (websocket-check (make-websocket-frame :opcode 'close :completep t))) + (should-not + (websocket-check (make-websocket-frame :opcode 'close :completep nil))) + (should-not + (websocket-check (make-websocket-frame :opcode 'close :completep t :payload ""))) + (should (websocket-check (make-websocket-frame :opcode 'text :completep nil + :payload "incompl"))) + (should (websocket-check (make-websocket-frame :opcode 'ping :completep t))) + (should (websocket-check (make-websocket-frame :opcode 'ping :completep t + :payload ""))) + (should (websocket-check (make-websocket-frame :opcode 'pong :completep t + :payload ""))) + (should-not (websocket-check (make-websocket-frame :opcode 'text)))) + +(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) (add-to-list 'processes-deleted proc))) + (websocket-close (websocket-inner-create + :conn "fake-conn" + :url t + :accept-string t + :on-close 'identity)) + (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 t) + (websocket-encode-frame frame2 t)))) + (flet ((websocket-process-frame + (websocket frame) + (lexical-let ((frame frame)) + (lambda () (push frame processed-frames)))) + (websocket-verify-headers (websocket output) t) + (websocket-close (websocket))) + (websocket-outer-filter fake-ws "HTTP/1.1 101 Switching Protocols\r\n") + (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-outer-filter-fragmented-header () + (let* ((on-open-calledp) + (websocket-closed-calledp) + (fake-ws (websocket-inner-create + :protocols '("websocket") + :conn t :url t :accept-string "17hG/VoPPd14L9xPSI7LtEr7PQc=" + :on-open (lambda (websocket) + (setq on-open-calledp t))))) + (flet ((websocket-close (websocket))) + (websocket-outer-filter fake-ws "HTTP/1.1 101 Web Socket Protocol Handsh") + (websocket-outer-filter fake-ws "ake\r\nConnection: Upgrade\r\n") + (websocket-outer-filter fake-ws "Upgrade: websocket\r\n") + (websocket-outer-filter fake-ws "Sec-websocket-Protocol: websocket\r\n") + (websocket-outer-filter fake-ws "Sec-WebSocket-Accept: 17hG/VoPPd14L9xPSI7LtEr7PQc=\r\n\r\n")))) + +(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") + (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" + "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"))) diff --git a/websocket.el b/websocket.el new file mode 100644 index 0000000..8db83c2 --- /dev/null +++ b/websocket.el @@ -0,0 +1,1034 @@ +;;; websocket.el --- Emacs WebSocket client and server + +;; Copyright (c) 2013, 2016 Free Software Foundation, Inc. + +;; Author: Andrew Hyatt +;; Keywords: Communication, Websocket, Server +;; Version: 1.6 +;; +;; 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 3 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 GNU Emacs. If not, see . + +;;; 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) +(require 'url-cookie) +(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.5" + "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-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 _ + (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)) + ;; Test for systems that don't have > 32 bits, and + ;; for those systems just return the value. + (low-32bits (if (= 0 (expt 2 32)) + val + (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 should-mask) + "Encode the FRAME struct to the binary representation. +We mask the frame or not, depending on SHOULD-MASK." + (let* ((opcode (websocket-frame-opcode frame)) + (payload (websocket-frame-payload frame)) + (fin (websocket-frame-completep frame)) + (payloadp (and payload + (memq opcode '(continuation ping pong text binary)))) + (mask-key (when should-mask (websocket-genbytes 4)))) + (apply 'unibyte-string + (let ((val (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 should-mask 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 should-mask) + (append mask-key nil)) + (when payloadp + (append (if should-mask (websocket-mask mask-key payload) + payload) + nil))))) + ;; We have to make sure the non-payload data is a full 32-bit frame + (if (= 1 (length val)) + (append val '(0)) val))))) + +(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 ping pong))) + (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) + (push elem result))))) + +(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." + (unless (string-match "^HTTP/1.1 \\([[:digit:]]+\\)" output) + (signal 'websocket-invalid-header "Invalid HTTP status line")) + (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 + :payload (websocket-frame-payload lex-frame) + :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." + (or + ;; Text, binary, and continuation frames need payloads + (and (memq (websocket-frame-opcode frame) '(text binary continuation)) + (websocket-frame-payload frame)) + ;; Pings and pongs may optionally have them + (memq (websocket-frame-opcode frame) '(ping pong)) + ;; And close shouldn't have any payload, and should always be complete. + (and (eq (websocket-frame-opcode frame) 'close) + (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) + ;; We mask only when we're a client, following the spec. + (websocket-encode-frame frame (not (websocket-server-p websocket))))) + +(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") + (websocket-try-callback 'websocket-on-close 'on-close websocket) + (when (websocket-openp websocket) + (websocket-send websocket + (make-websocket-frame :opcode 'close + :completep t)) + (setf (websocket-ready-state websocket) 'closed)) + (delete-process (websocket-conn websocket))) + +(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\")). + +Cookies that are set via `url-cookie-store' will be used during +communication with the server, and cookies received from the +server will be stored in the same cookie storage that the +`url-cookie' package uses. + +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)) + (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))) + (if (eq type 'plain) + (make-network-process :name name :buffer nil :host host + :service port :nowait nil) + (condition-case-unless-debug nil + (open-network-stream name nil 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)))) + (unless conn (error "Could not establish the websocket connection to %s" url)) + (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) + (when (and + (member (process-status process) '(closed failed exit signal)) + (not (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-process-headers (url headers) + "On opening URL, process the HEADERS sent from the server." + (when (string-match "Set-Cookie: \(.*\)\r\n" headers) + ;; The url-current-object is assumed to be set by + ;; url-cookie-handle-set-cookie. + (let ((url-current-object (url-generic-parse-url url))) + (url-cookie-handle-set-cookie (match-string 1 headers))))) + +(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) + (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))) + (if (and (setq header-end-pos (string-match "\r\n\r\n" text)) + (setq start-point (+ 4 header-end-pos))) + (progn + (condition-case err + (progn + (websocket-verify-response-code text) + (websocket-verify-headers websocket text) + (websocket-process-headers (websocket-url 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)) + (setf (websocket-inflight-input websocket) text))) + (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) + (list 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) + (let ((x (first (split-string ext "; ?")))) + (unless (or (member x (websocket-extensions websocket)) + (member x extra-extensions)) + (push x extra-extensions)))) + (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. +If the plist contains a `:host' HOST pair, this value will be +used to configure the addresses the socket listens on. The symbol +`local' specifies the local host. If unspecified or nil, the +socket will listen on all addresses. + +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 %s" port) + :server t + :family 'ipv4 + :filter 'websocket-server-filter + :log 'websocket-server-accept + :filter-multibyte nil + :plist plist + :host (plist-get plist :host) + :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) + (unless (member ws to-delete) + (push ws to-delete)) + (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 + :server-p t + :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))))) + (unless (member ws websocket-server-websockets) + (push ws websocket-server-websockets)) + (process-put client :websocket ws) + (set-process-coding-system client 'binary 'binary) + (set-process-sentinel client + (lambda (process change) + (let ((websocket (process-get process :websocket))) + (websocket-debug websocket "State change to %s" change) + (when (and + (member (process-status process) '(closed failed exit signal)) + (not (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'." + (let* ((parsed-url (url-generic-parse-url url)) + (host-port (if (url-port-if-non-default parsed-url) + (format "%s:%s" (url-host parsed-url) (url-port parsed-url)) + (url-host parsed-url))) + (cookie-header (url-cookie-generate-header-lines + host-port (car (url-path-and-query parsed-url)) + (equal (url-type parsed-url) "wss")))) + (format (concat "Host: %s\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: %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 ", "))) + (when cookie-header cookie-header) + "\r\n") + host-port + key + 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