├── COPYING ├── README.org ├── testserver.py ├── websocket-functional-test.el ├── websocket-test.el └── websocket.el /COPYING: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License along 307 | with this program; if not, write to the Free Software Foundation, Inc., 308 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 309 | 310 | Also add information on how to contact you by electronic and paper mail. 311 | 312 | If the program is interactive, make it output a short notice like this 313 | when it starts in an interactive mode: 314 | 315 | Gnomovision version 69, Copyright (C) year name of author 316 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 317 | This is free software, and you are welcome to redistribute it 318 | under certain conditions; type `show c' for details. 319 | 320 | The hypothetical commands `show w' and `show c' should show the appropriate 321 | parts of the General Public License. Of course, the commands you use may 322 | be called something other than `show w' and `show c'; they could even be 323 | mouse-clicks or menu items--whatever suits your program. 324 | 325 | You should also get your employer (if you work as a programmer) or your 326 | school, if any, to sign a "copyright disclaimer" for the program, if 327 | necessary. Here is a sample; alter the names: 328 | 329 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 330 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 331 | 332 | , 1 April 1989 333 | Ty Coon, President of Vice 334 | 335 | This General Public License does not permit incorporating your program into 336 | proprietary programs. If your program is a subroutine library, you may 337 | consider it more useful to permit linking proprietary applications with the 338 | library. If this is what you want to do, use the GNU Lesser General 339 | Public License instead of this License. -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Description 2 | This is a elisp library for websocket clients to talk to websocket 3 | servers, and for websocket servers to accept connections from 4 | websocket clients. This library is designed to be used by other 5 | library writers, to write apps that use websockets, and is not useful 6 | by itself. 7 | 8 | An example of how to use the library is in the 9 | [[https://github.com/ahyatt/emacs-websocket/blob/master/websocket-functional-test.el][websocket-functional-test.el]] file. 10 | 11 | This library is compatible with emacs 23 and 24, although only emacs 12 | 24 support secure websockets. 13 | 14 | * Version release checklist 15 | 16 | Each version that is released should be checked with this checklist: 17 | 18 | - [ ] All ert test passing 19 | - [ ] Functional test passing on emacs 23 and 24 20 | - [ ] websocket.el byte compiling cleanly. 21 | 22 | * Existing clients: 23 | 24 | - [[https://github.com/tkf/emacs-ipython-notebook][Emacs IPython Notebook]] 25 | - [[https://github.com/syohex/emacs-realtime-markdown-viewer][Emacs Realtime Markdown Viewer]] 26 | - [[https://github.com/jscheid/kite][Kite]] 27 | - [[https://github.com/ancane/markdown-preview-mode][Markdown-preview-mode]] 28 | - [[https://github.com/org-roam/org-roam-ui][Org-Roam-UI]] 29 | 30 | If you are using this module for your own emacs package, please let me 31 | know by editing this file, adding your project, and sending a pull 32 | request to this repository. 33 | 34 | -------------------------------------------------------------------------------- /testserver.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python3 2 | import logging 3 | import tornado 4 | import tornado.web 5 | from tornado import httpserver 6 | from tornado import ioloop 7 | from tornado import websocket 8 | 9 | 10 | class EchoWebSocket(websocket.WebSocketHandler): 11 | 12 | def open(self): 13 | logging.info("OPEN") 14 | 15 | def on_message(self, message): 16 | logging.info("ON_MESSAGE: {0}".format(message)) 17 | self.write_message(message) 18 | 19 | def on_close(self): 20 | logging.info("ON_CLOSE") 21 | 22 | def allow_draft76(self): 23 | return False 24 | 25 | 26 | if __name__ == "__main__": 27 | import tornado.options 28 | tornado.options.parse_command_line() 29 | application = tornado.web.Application([ 30 | (r"/", EchoWebSocket), 31 | ]) 32 | server = httpserver.HTTPServer(application) 33 | server.listen(9999, "127.0.0.1") 34 | logging.info("STARTED: Server start listening") 35 | ioloop.IOLoop.instance().start() 36 | -------------------------------------------------------------------------------- /websocket-functional-test.el: -------------------------------------------------------------------------------- 1 | ;;; websocket-functional-test.el --- Simple functional testing 2 | 3 | ;; Copyright (c) 2013, 2016 Free Software Foundation, Inc. 4 | 5 | ;; This program is free software; you can redistribute it and/or 6 | ;; modify it under the terms of the GNU General Public License as 7 | ;; published by the Free Software Foundation; either version 2 of the 8 | ;; License, or (at your option) any later version. 9 | ;; 10 | ;; This program is distributed in the hope that it will be useful, but 11 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | ;; General Public License for more details. 14 | ;; 15 | ;; You should have received a copy of the GNU General Public License 16 | ;; along with GNU Emacs. If not, see . 17 | 18 | ;;; Commentary: 19 | 20 | ;; These are functional tests that may fail for various environmental reasons, 21 | ;; such as blocked ports. For example Windows users have to have gnutls DLLs in 22 | ;; the Emacs bin directory for this to work. A firewall may also interfere with 23 | ;; these tests. 24 | ;; 25 | ;; These tests are written to test the basic connectivity and message-sending. 26 | ;; Corner-cases and error handling is tested in websocket-test.el. 27 | 28 | (require 'tls) ;; tests a particular bug we had on Emacs 23 29 | (require 'websocket) 30 | (require 'cl) 31 | 32 | ;;; Code: 33 | 34 | (defmacro websocket-test-wait-with-timeout (timeout &rest body) 35 | "Run BODY until true or TIMEOUT (in seconds) is reached. 36 | 37 | Will return false if the timeout was reached. This macro is not 38 | written to be used widely." 39 | `(let ((begin (current-time)) 40 | (result nil)) 41 | (while (and (< (- (float-time (time-subtract (current-time) begin))) ,timeout) (not result)) 42 | (setq result ,@body) 43 | (sleep-for 0.5)) 44 | result)) 45 | 46 | (defun websocket-functional-client-test (wstest-server-url) 47 | "Run the main part of an ert test against WSTEST-SERVER-URL." 48 | ;; the server may have an untrusted certificate, for the test to proceed, we 49 | ;; need to disable trust checking. 50 | (let* ((tls-checktrust nil) 51 | (wstest-closed nil) 52 | (wstest-msg) 53 | (wstest-server-proc) 54 | (wstest-ws 55 | (websocket-open 56 | wstest-server-url 57 | :on-message (lambda (_websocket frame) 58 | (setq wstest-msg (websocket-frame-text frame))) 59 | :on-close (lambda (_websocket) (setq wstest-closed t))))) 60 | (should (websocket-test-wait-with-timeout 2 (websocket-openp wstest-ws))) 61 | (should (websocket-test-wait-with-timeout 2 (eq 'open (websocket-ready-state wstest-ws)))) 62 | (should (null wstest-msg)) 63 | (websocket-send-text wstest-ws "Hi!") 64 | (should (websocket-test-wait-with-timeout 5 (equal wstest-msg "Hi!"))) 65 | (websocket-close wstest-ws))) 66 | 67 | (ert-deftest websocket-client-with-local-server () 68 | ;; If testserver.py cannot start, this test will fail. 69 | (let ((proc (start-process 70 | "websocket-testserver" "*websocket-testserver*" 71 | "python3" "testserver.py" "--log_to_stderr" "--logging=debug"))) 72 | (when proc 73 | (sleep-for 1) 74 | (websocket-functional-client-test "ws://127.0.0.1:9999")))) 75 | 76 | (ert-deftest websocket-server () 77 | (let* ((wstest-closed) 78 | (wstest-msg) 79 | (server-conn (websocket-server 80 | 9998 81 | :host 'local 82 | :on-message (lambda (ws frame) 83 | (websocket-send-text 84 | ws (websocket-frame-text frame))) 85 | :on-close (lambda (_websocket) 86 | (setq wstest-closed t)))) 87 | (wstest-ws (websocket-open 88 | "ws://localhost:9998" 89 | :on-message (lambda (_websocket frame) 90 | (setq wstest-msg (websocket-frame-text frame)))))) 91 | (should (websocket-test-wait-with-timeout 1 (websocket-openp wstest-ws))) 92 | (websocket-send-text wstest-ws "你好") 93 | (should (websocket-test-wait-with-timeout 1 (equal wstest-msg "你好"))) 94 | (websocket-server-close server-conn) 95 | (should (websocket-test-wait-with-timeout 1 wstest-closed)))) 96 | 97 | (provide 'websocket-functional-test) 98 | ;;; websocket-functional-test.el ends here 99 | -------------------------------------------------------------------------------- /websocket-test.el: -------------------------------------------------------------------------------- 1 | ;;; websocket-test.el --- Unit tests for the websocket layer 2 | 3 | ;; Copyright (c) 2013 Free Software Foundation, Inc. 4 | ;; 5 | ;; Author: Andrew Hyatt 6 | ;; Maintainer: Andrew Hyatt 7 | ;; 8 | ;; This program is free software; you can redistribute it and/or 9 | ;; modify it under the terms of the GNU General Public License as 10 | ;; published by the Free Software Foundation; either version 2 of the 11 | ;; License, or (at your option) any later version. 12 | ;; 13 | ;; This program is distributed in the hope that it will be useful, but 14 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | ;; General Public License for more details. 17 | ;; 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with GNU Emacs. If not, see . 20 | 21 | ;;; Commentary: 22 | ;; This defines and runs ert unit tests. You can download ert from: 23 | ;; http://github.com/ohler/ert, it also comes with Emacs 24 and above. 24 | 25 | (require 'ert) 26 | (require 'websocket) 27 | (eval-when-compile (require 'cl)) 28 | 29 | (ert-deftest websocket-genbytes-length () 30 | (loop repeat 100 31 | do (should (= (string-bytes (websocket-genbytes 16)) 16)))) 32 | 33 | (ert-deftest websocket-calculate-accept () 34 | ;; This example comes straight from RFC 6455 35 | (should 36 | (equal "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" 37 | (websocket-calculate-accept "dGhlIHNhbXBsZSBub25jZQ==")))) 38 | 39 | (defconst websocket-test-hello "\x81\x05\x48\x65\x6c\x6c\x6f" 40 | "'Hello' string example, taken from the RFC.") 41 | 42 | (defconst websocket-test-masked-hello 43 | "\x81\x85\x37\xfa\x21\x3d\x7f\x9f\x4d\x51\x58" 44 | "'Hello' masked string example, taken from the RFC.") 45 | 46 | (ert-deftest websocket-get-bytes () 47 | (should (equal #x5 (websocket-get-bytes "\x5" 1))) 48 | (should (equal #x101 (websocket-get-bytes "\x1\x1" 2))) 49 | (should (equal #xffffff 50 | (websocket-get-bytes "\x0\x0\x0\x0\x0\xFF\xFF\xFF" 8))) 51 | (should-error (websocket-get-bytes "\x0\x0\x0\x1\x0\x0\x0\x1" 8) 52 | :type 'websocket-unparseable-frame) 53 | (should-error (websocket-get-bytes "\x0\x0\x0" 3)) 54 | (should-error (websocket-get-bytes "\x0" 2) :type 'websocket-unparseable-frame)) 55 | 56 | (ert-deftest websocket-get-opcode () 57 | (should (equal 'text (websocket-get-opcode websocket-test-hello)))) 58 | 59 | (ert-deftest websocket-get-payload-len () 60 | (should (equal '(5 . 1) 61 | (websocket-get-payload-len 62 | (substring websocket-test-hello 1)))) 63 | (should (equal '(200 . 3) 64 | (websocket-get-payload-len 65 | (bindat-pack '((:len u8) (:val u16)) 66 | `((:len . 126) 67 | (:val . 200)))))) 68 | ;; we don't want to hit up any limits even on strange emacs builds, 69 | ;; so this test has a pretty small test value 70 | (should (equal '(70000 . 9) 71 | (websocket-get-payload-len 72 | (bindat-pack '((:len u8) (:val vec 2 u32)) 73 | `((:len . 127) 74 | (:val . [0 70000]))))))) 75 | 76 | (ert-deftest websocket-read-frame () 77 | (should (equal (make-websocket-frame :opcode 'text :payload "Hello" 78 | :length (length websocket-test-hello) 79 | :completep t) 80 | (websocket-read-frame websocket-test-hello))) 81 | (should (equal (make-websocket-frame :opcode 'text :payload "Hello" 82 | :length (length websocket-test-hello) 83 | :completep t) 84 | (websocket-read-frame (concat websocket-test-hello 85 | "should-not-be-read")))) 86 | (should (equal (make-websocket-frame :opcode 'text :payload "Hello" 87 | :length (length websocket-test-masked-hello) 88 | :completep t) 89 | (websocket-read-frame websocket-test-masked-hello))) 90 | (should (equal (make-websocket-frame :opcode 'text :payload "Hello" 91 | :length (length websocket-test-hello) 92 | :completep nil) 93 | (websocket-read-frame 94 | (concat (unibyte-string 95 | (logand (string-to-char 96 | (substring websocket-test-hello 0 1)) 97 | 127)) 98 | (substring websocket-test-hello 1))))) 99 | (dotimes (i (- (length websocket-test-hello) 1)) 100 | (should-not (websocket-read-frame 101 | (substring websocket-test-hello 0 102 | (- (length websocket-test-hello) (+ i 1)))))) 103 | (dotimes (i (- (length websocket-test-masked-hello) 1)) 104 | (should-not (websocket-read-frame 105 | (substring websocket-test-masked-hello 0 106 | (- (length websocket-test-masked-hello) (+ i 1))))))) 107 | 108 | (defun websocket-test-header-with-lines (&rest lines) 109 | (mapconcat 'identity (append lines '("\r\n")) "\r\n")) 110 | 111 | (ert-deftest websocket-verify-response-code () 112 | (should (websocket-verify-response-code "HTTP/1.1 101")) 113 | (should 114 | (equal '(400) (cdr (should-error (websocket-verify-response-code "HTTP/1.1 400") 115 | :type 'websocket-received-error-http-response)))) 116 | (should 117 | (equal '(200) (cdr (should-error (websocket-verify-response-code "HTTP/1.1 200"))))) 118 | (should-error (websocket-verify-response-code "HTTP/1.") 119 | :type 'websocket-invalid-header)) 120 | 121 | (ert-deftest websocket-verify-headers () 122 | (let ((accept "Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=") 123 | (accept-alt-case "Sec-Websocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=") 124 | (invalid-accept "Sec-WebSocket-Accept: bad") 125 | (upgrade "Upgrade: websocket") 126 | (upgrade-alt-case "Upgrade: Websocket") 127 | (connection "Connection: upgrade") 128 | (ws (websocket-inner-create 129 | :conn "fake-conn" :url "ws://foo/bar" 130 | :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=")) 131 | (ws-with-protocol 132 | (websocket-inner-create 133 | :conn "fake-conn" :url "ws://foo/bar" 134 | :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" 135 | :protocols '("myprotocol"))) 136 | (ws-with-extensions 137 | (websocket-inner-create 138 | :conn "fake-conn" :url "ws://foo/bar" 139 | :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" 140 | :extensions '("ext1" "ext2")))) 141 | (should (websocket-verify-headers 142 | ws 143 | (websocket-test-header-with-lines accept upgrade connection))) 144 | ;; Force case sensitivity to make sure we aren't too case sensitive. 145 | (let ((case-fold-search nil)) 146 | (should (websocket-verify-headers 147 | ws 148 | (websocket-test-header-with-lines accept-alt-case upgrade-alt-case connection)))) 149 | (should-error 150 | (websocket-verify-headers 151 | ws 152 | (websocket-test-header-with-lines invalid-accept upgrade connection)) 153 | :type 'websocket-invalid-header) 154 | (should-error (websocket-verify-headers 155 | ws 156 | (websocket-test-header-with-lines upgrade connection)) 157 | :type 'websocket-invalid-header) 158 | (should-error (websocket-verify-headers 159 | ws 160 | (websocket-test-header-with-lines accept connection)) 161 | :type 'websocket-invalid-header) 162 | (should-error (websocket-verify-headers 163 | ws 164 | (websocket-test-header-with-lines accept upgrade)) 165 | :type 'websocket-invalid-header) 166 | (should-error (websocket-verify-headers 167 | ws-with-protocol 168 | (websocket-test-header-with-lines accept upgrade connection)) 169 | :type 'websocket-invalid-header) 170 | (should-error 171 | (websocket-verify-headers 172 | ws-with-protocol 173 | (websocket-test-header-with-lines accept upgrade connection 174 | "Sec-Websocket-Protocol: foo")) 175 | :type 'websocket-invalid-header) 176 | (should 177 | (websocket-verify-headers 178 | ws-with-protocol 179 | (websocket-test-header-with-lines accept upgrade connection 180 | "Sec-Websocket-Protocol: myprotocol"))) 181 | (should (equal '("myprotocol") 182 | (websocket-negotiated-protocols ws-with-protocol))) 183 | (should-error 184 | (websocket-verify-headers 185 | ws-with-extensions 186 | (websocket-test-header-with-lines accept upgrade connection 187 | "Sec-Websocket-Extensions: foo"))) 188 | (should 189 | (websocket-verify-headers 190 | ws-with-extensions 191 | (websocket-test-header-with-lines 192 | accept upgrade connection "Sec-Websocket-Extensions: ext1, ext2; a=1"))) 193 | (should (equal '("ext1" "ext2; a=1") 194 | (websocket-negotiated-extensions ws-with-extensions))) 195 | (should 196 | (websocket-verify-headers 197 | ws-with-extensions 198 | (websocket-test-header-with-lines accept upgrade connection 199 | "Sec-Websocket-Extensions: ext1" 200 | "Sec-Websocket-Extensions: ext2; a=1"))) 201 | (should (equal '("ext1" "ext2; a=1") 202 | (websocket-negotiated-extensions ws-with-extensions))))) 203 | 204 | (ert-deftest websocket-mask-is-unibyte () 205 | (should-not (multibyte-string-p (websocket-mask "\344\275\240\345\245\275" "abcdef")))) 206 | 207 | (ert-deftest websocket-frame-correctly-encoded () 208 | ;; This example comes from https://github.com/ahyatt/emacs-websocket/issues/58. 209 | (cl-letf ((text "{\"parent_header\":{},\"header\":{\"msg_id\":\"a2940bc8-619e-4872-97bd-4c8d6fb93017\",\"msg_type\":\"history_request\",\"version\":\"5.3\",\"username\":\"n\",\"session\":\"409cf442-74ba-462f-8183-6652503005af\",\"date\":\"2019-06-20T02:17:43.925049-0500\"},\"content\":{\"output\":false,\"raw\":false,\"hist_access_type\":\"tail\",\"n\":100},\"metadata\":{},\"buffers\":[],\"channel\":\"shell\"}") 210 | ((symbol-function #'websocket-genbytes) 211 | (lambda (&rest _) "\10\206\356\224"))) 212 | (let ((frame (websocket-read-frame 213 | (websocket-encode-frame 214 | (make-websocket-frame :opcode 'text 215 | :payload (encode-coding-string text 'raw-text) 216 | :completep t) 217 | t)))) 218 | (should frame) 219 | (should (equal (websocket-frame-payload frame) text))))) 220 | 221 | (ert-deftest websocket-create-headers () 222 | (let ((base-headers (concat "Host: www.example.com\r\n" 223 | "Upgrade: websocket\r\n" 224 | "Connection: Upgrade\r\n" 225 | "Sec-WebSocket-Key: key\r\n" 226 | "Sec-WebSocket-Version: 13\r\n"))) 227 | (cl-letf (((symbol-function 'url-cookie-generate-header-lines) 228 | (lambda (host localpart secure) ""))) 229 | (should (equal (concat base-headers "\r\n") 230 | (websocket-create-headers "ws://www.example.com/path" 231 | "key" nil nil nil))) 232 | (should (equal (concat base-headers 233 | "Sec-WebSocket-Protocol: protocol\r\n\r\n") 234 | (websocket-create-headers "ws://www.example.com/path" 235 | "key" '("protocol") nil nil))) 236 | (should (equal 237 | (concat base-headers 238 | "Sec-WebSocket-Extensions: ext1; a; b=2, ext2\r\n\r\n") 239 | (websocket-create-headers "ws://www.example.com/path" 240 | "key" nil 241 | '(("ext1" . ("a" "b=2")) 242 | ("ext2")) nil))) 243 | (should (equal 244 | (concat base-headers "Foo: bar\r\nBaz: boo\r\n\r\n") 245 | (websocket-create-headers "ws://www.example.com/path" 246 | "key" nil nil '(("Foo" . "bar") ("Baz" . "boo")))))) 247 | (cl-letf (((symbol-function 'url-cookie-generate-header-lines) 248 | (lambda (host localpart secure) 249 | (should (equal host "www.example.com:123")) 250 | (should (equal localpart "/path")) 251 | (should secure) 252 | "Cookie: foo=bar\r\n"))) 253 | (should (equal (websocket-create-headers "wss://www.example.com:123/path" 254 | "key" nil nil nil) 255 | (concat 256 | "Host: www.example.com:123\r\n" 257 | "Upgrade: websocket\r\n" 258 | "Connection: Upgrade\r\n" 259 | "Sec-WebSocket-Key: key\r\n" 260 | "Sec-WebSocket-Version: 13\r\n" 261 | "Cookie: foo=bar\r\n\r\n")))) 262 | (should 263 | (string-match 264 | "Host: www.example.com:123\r\n" 265 | (websocket-create-headers "ws://www.example.com:123/path" "key" nil nil nil))))) 266 | 267 | (ert-deftest websocket-process-headers () 268 | (cl-flet ((url-cookie-handle-set-cookie 269 | (text) 270 | (should (equal text "foo=bar;")) 271 | ;; test that we have set the implicit buffer variable needed 272 | ;; by url-cookie-handle-set-cookie 273 | (should (equal url-current-object 274 | (url-generic-parse-url "ws://example.com/path"))))) 275 | (websocket-process-headers "ws://example.com/path" 276 | (concat 277 | "HTTP/1.1 101 Switching Protocols\r\n" 278 | "Upgrade: websocket\r\n" 279 | "Connection: Upgrade\r\n" 280 | "Set-Cookie: foo=bar;\r\n\r\n"))) 281 | (cl-flet ((url-cookie-handle-set-cookie (text) (should nil))) 282 | (websocket-process-headers "ws://example.com/path" 283 | "HTTP/1.1 101 Switching Protocols\r\n"))) 284 | 285 | (ert-deftest websocket-process-frame () 286 | (let* ((sent) 287 | (processed) 288 | (deleted) 289 | (websocket (websocket-inner-create 290 | :conn t :url t 291 | :on-message (lambda (websocket frame) 292 | (setq 293 | processed 294 | (websocket-frame-payload frame))) 295 | :accept-string t))) 296 | (dolist (opcode '(text binary continuation)) 297 | (setq processed nil) 298 | (should (equal 299 | "hello" 300 | (progn 301 | (funcall (websocket-process-frame 302 | websocket 303 | (make-websocket-frame :opcode opcode :payload "hello"))) 304 | processed)))) 305 | (setq sent nil) 306 | (cl-letf (((symbol-function 'websocket-send) 307 | (lambda (websocket content) (setq sent content)))) 308 | (should (equal 309 | (make-websocket-frame :opcode 'pong :payload "data" :completep t) 310 | (progn 311 | (funcall (websocket-process-frame websocket 312 | (make-websocket-frame :opcode 'ping 313 | :payload "data"))) 314 | sent)))) 315 | (cl-letf (((symbol-function 'delete-process) 316 | (lambda (conn) (setq deleted t)))) 317 | (should (progn 318 | (funcall 319 | (websocket-process-frame websocket 320 | (make-websocket-frame :opcode 'close))) 321 | deleted))))) 322 | 323 | (ert-deftest websocket-process-frame-error-handling () 324 | (let* ((error-called) 325 | (websocket (websocket-inner-create 326 | :conn t :url t :accept-string t 327 | :on-message (lambda (websocket frame) 328 | (message "In on-message") 329 | (error "err")) 330 | :on-error (lambda (ws type err) 331 | (should (eq 'on-message type)) 332 | (setq error-called t))))) 333 | (funcall (websocket-process-frame websocket 334 | (make-websocket-frame :opcode 'text 335 | :payload "hello"))) 336 | (should error-called))) 337 | 338 | (ert-deftest websocket-to-bytes () 339 | ;; We've tested websocket-get-bytes by itself, now we can use it to 340 | ;; help test websocket-to-bytes. 341 | (should (equal 30 (websocket-get-bytes (websocket-to-bytes 30 1) 1))) 342 | (should (equal 300 (websocket-get-bytes (websocket-to-bytes 300 2) 2))) 343 | (should (equal 70000 (websocket-get-bytes (websocket-to-bytes 70000 8) 8))) 344 | ;; Only run if the number we're testing with is not more than the system can 345 | ;; handle. 346 | (if (equal "1" (calc-eval (format "536870912 < %d" most-positive-fixnum))) 347 | (should-error (websocket-to-bytes 536870912 8) 348 | :type 'websocket-frame-too-large)) 349 | (should-error (websocket-to-bytes 30 3)) 350 | (should-error (websocket-to-bytes 300 1)) 351 | ;; I'd like to test the error for 32-byte systems on 8-byte lengths, 352 | ;; but elisp does not allow us to temporarily set constants such as 353 | ;; most-positive-fixnum. 354 | ) 355 | 356 | (ert-deftest websocket-encode-frame () 357 | ;; We've tested websocket-read-frame, now we can use that to help 358 | ;; test websocket-encode-frame. 359 | (should (equal 360 | websocket-test-hello 361 | (websocket-encode-frame 362 | (make-websocket-frame :opcode 'text :payload "Hello" :completep t) nil))) 363 | (dolist (len '(200 70000)) 364 | (let ((long-string (make-string len ?x))) 365 | (should (equal long-string 366 | (websocket-frame-payload 367 | (websocket-read-frame 368 | (websocket-encode-frame 369 | (make-websocket-frame :opcode 'text 370 | :payload long-string) t))))))) 371 | (cl-letf (((symbol-function 'websocket-genbytes) 372 | (lambda (n) (substring websocket-test-masked-hello 2 6)))) 373 | (should (equal websocket-test-masked-hello 374 | (websocket-encode-frame 375 | (make-websocket-frame :opcode 'text :payload "Hello" 376 | :completep t) t)))) 377 | (should-not 378 | (websocket-frame-completep 379 | (websocket-read-frame 380 | (websocket-encode-frame (make-websocket-frame :opcode 'text 381 | :payload "Hello" 382 | :completep nil) t)))) 383 | (should (equal 'close (websocket-frame-opcode 384 | (websocket-read-frame 385 | (websocket-encode-frame 386 | (make-websocket-frame :opcode 'close :completep t) t))))) 387 | (dolist (opcode '(ping pong)) 388 | (let ((read-frame (websocket-read-frame 389 | (websocket-encode-frame 390 | (make-websocket-frame :opcode opcode 391 | :payload "data" 392 | :completep t) t)))) 393 | (should read-frame) 394 | (should (equal 395 | opcode 396 | (websocket-frame-opcode read-frame))) 397 | (should (equal 398 | "data" (websocket-frame-payload read-frame))))) 399 | ;; A frame should be four bytes, even for no-data pings. 400 | (should (equal 2 (websocket-frame-length 401 | (websocket-read-frame 402 | (websocket-encode-frame 403 | (make-websocket-frame :opcode 'ping :completep t) t)))))) 404 | 405 | (ert-deftest websocket-check () 406 | (should (websocket-check (make-websocket-frame :opcode 'close :completep t))) 407 | (should-not 408 | (websocket-check (make-websocket-frame :opcode 'close :completep nil))) 409 | (should-not 410 | (websocket-check (make-websocket-frame :opcode 'close :completep t :payload ""))) 411 | (should (websocket-check (make-websocket-frame :opcode 'text :completep nil 412 | :payload "incompl"))) 413 | (should (websocket-check (make-websocket-frame :opcode 'ping :completep t))) 414 | (should (websocket-check (make-websocket-frame :opcode 'ping :completep t 415 | :payload ""))) 416 | (should (websocket-check (make-websocket-frame :opcode 'pong :completep t 417 | :payload ""))) 418 | (should-not (websocket-check (make-websocket-frame :opcode 'text)))) 419 | 420 | (ert-deftest websocket-close () 421 | (let ((sent-frames) 422 | (processes-deleted)) 423 | (cl-letf (((symbol-function 'websocket-send) 424 | (lambda (websocket frame) (push frame sent-frames))) 425 | ((symbol-function 'websocket-openp) 426 | (lambda (websocket) t)) 427 | ((symbol-function 'kill-buffer) (lambda (buffer) t)) 428 | ((symbol-function 'delete-process) 429 | (lambda (proc) (add-to-list 'processes-deleted proc)))) 430 | (websocket-close (websocket-inner-create 431 | :conn "fake-conn" 432 | :url t 433 | :accept-string t 434 | :on-close 'identity)) 435 | (should (equal sent-frames (list 436 | (make-websocket-frame :opcode 'close 437 | :completep t)))) 438 | (should (equal processes-deleted '("fake-conn")))))) 439 | 440 | (ert-deftest websocket-outer-filter () 441 | (let* ((fake-ws (websocket-inner-create 442 | :conn t :url t :accept-string t 443 | :on-open (lambda (websocket) 444 | (should (eq (websocket-ready-state websocket) 445 | 'open)) 446 | (setq open-callback-called t) 447 | (error "Ignore me!")) 448 | :on-error (lambda (ws type err)))) 449 | (processed-frames) 450 | (frame1 (make-websocket-frame :opcode 'text :payload "foo" :completep t 451 | :length 9)) 452 | (frame2 (make-websocket-frame :opcode 'text :payload "bar" :completep t 453 | :length 9)) 454 | (open-callback-called) 455 | (websocket-frames 456 | (concat 457 | (websocket-encode-frame frame1 t) 458 | (websocket-encode-frame frame2 t)))) 459 | (cl-letf (((symbol-function 'websocket-process-frame) 460 | (lambda (websocket frame) 461 | (lexical-let ((frame frame)) 462 | (lambda () (push frame processed-frames))))) 463 | ((symbol-function 'websocket-verify-headers) 464 | (lambda (websocket output) t)) 465 | ((symbol-function 'websocket-close) (lambda (websocket) t))) 466 | (websocket-outer-filter fake-ws "HTTP/1.1 101 Switching Protocols\r\n") 467 | (websocket-outer-filter fake-ws "Sec-") 468 | (should (eq (websocket-ready-state fake-ws) 'connecting)) 469 | (should-not open-callback-called) 470 | (websocket-outer-filter fake-ws "WebSocket-Accept: acceptstring") 471 | (should-not open-callback-called) 472 | (websocket-outer-filter fake-ws (concat 473 | "\r\n\r\n" 474 | (substring websocket-frames 0 2))) 475 | (should open-callback-called) 476 | (websocket-outer-filter fake-ws (substring websocket-frames 2)) 477 | (should (equal (list frame2 frame1) processed-frames)) 478 | (should-not (websocket-inflight-input fake-ws))) 479 | (cl-letf (((symbol-function 'websocket-close) (lambda (websocket) t))) 480 | (let ((on-error-called)) 481 | (setf (websocket-ready-state fake-ws) 'connecting) 482 | (setf (websocket-on-open fake-ws) (lambda (ws &rest _) t)) 483 | (setf (websocket-on-error fake-ws) 484 | (lambda (_ type err) 485 | (should (eq type 'on-open)) 486 | (should (equal '(websocket-received-error-http-response 500) err)) 487 | (setq on-error-called t))) 488 | (websocket-outer-filter fake-ws "HTTP/1.1 500\r\n\r\n") 489 | (should on-error-called))))) 490 | 491 | (ert-deftest websocket-outer-filter-bad-connection () 492 | (let* ((on-open-calledp) 493 | (websocket-closed-calledp) 494 | (fake-ws (websocket-inner-create 495 | :conn t :url t :accept-string t 496 | :on-open (lambda (websocket) 497 | (setq on-open-calledp t))))) 498 | (cl-letf (((symbol-function 'websocket-verify-response-code) 499 | (lambda (output) t)) 500 | ((symbol-function 'websocket-verify-headers) 501 | (lambda (websocket output) (error "Bad headers!"))) 502 | ((symbol-function 'websocket-close) 503 | (lambda (websocket) (setq websocket-closed-calledp t)))) 504 | (condition-case err 505 | (progn (websocket-outer-filter fake-ws "HTTP/1.1 101\r\n\r\n") 506 | (error "Should have thrown an error!")) 507 | (error 508 | (should-not on-open-calledp) 509 | (should websocket-closed-calledp)))))) 510 | 511 | (ert-deftest websocket-outer-filter-fragmented-header () 512 | (let* ((on-open-calledp) 513 | (websocket-closed-calledp) 514 | (fake-ws (websocket-inner-create 515 | :protocols '("websocket") 516 | :conn t :url t :accept-string "17hG/VoPPd14L9xPSI7LtEr7PQc=" 517 | :on-open (lambda (websocket) 518 | (setq on-open-calledp t))))) 519 | (cl-letf (((symbol-function 'websocket-close) (lambda (websocket) t))) 520 | (websocket-outer-filter fake-ws "HTTP/1.1 101 Web Socket Protocol Handsh") 521 | (websocket-outer-filter fake-ws "ake\r\nConnection: Upgrade\r\n") 522 | (websocket-outer-filter fake-ws "Upgrade: websocket\r\n") 523 | (websocket-outer-filter fake-ws "Sec-websocket-Protocol: websocket\r\n") 524 | (websocket-outer-filter fake-ws "Sec-WebSocket-Accept: 17hG/VoPPd14L9xPSI7LtEr7PQc=\r\n\r\n")))) 525 | 526 | (ert-deftest websocket-send-text () 527 | (cl-letf (((symbol-function 'websocket-send) 528 | (lambda (ws frame) 529 | (should (equal 530 | (websocket-frame-payload frame) 531 | "\344\275\240\345\245\275"))))) 532 | (websocket-send-text nil "你好"))) 533 | 534 | (ert-deftest websocket-send () 535 | (let ((ws (websocket-inner-create :conn t :url t :accept-string t))) 536 | (cl-letf (((symbol-function 'websocket-ensure-connected) (lambda (websocket) t)) 537 | ((symbol-function 'websocket-openp) (lambda (websocket) t)) 538 | ((symbol-function 'process-send-string) (lambda (conn string) t))) 539 | ;; Just make sure there is no error. 540 | (websocket-send ws (make-websocket-frame :opcode 'ping 541 | :completep t))) 542 | (should-error (websocket-send ws 543 | (make-websocket-frame :opcode 'text))) 544 | (should-error (websocket-send ws 545 | (make-websocket-frame :opcode 'close 546 | :payload "bye!" 547 | :completep t)) 548 | :type 'websocket-illegal-frame) 549 | (should-error (websocket-send ws 550 | (make-websocket-frame :opcode :close)) 551 | :type 'websocket-illegal-frame))) 552 | 553 | (ert-deftest websocket-verify-client-headers () 554 | (let* ((http "HTTP/1.1") 555 | (host "Host: authority") 556 | (upgrade "Upgrade: websocket") 557 | (key (format "Sec-Websocket-Key: %s" "key")) 558 | (version "Sec-Websocket-Version: 13") 559 | (protocol "Sec-Websocket-Protocol: protocol") 560 | (extensions1 "Sec-Websocket-Extensions: foo") 561 | (extensions2 "Sec-Websocket-Extensions: bar; baz=2") 562 | (all-required-headers (list host upgrade key version))) 563 | ;; Test that all these headers are necessary 564 | (should (equal 565 | '(:key "key" :protocols ("protocol") :extensions ("foo" "bar; baz=2")) 566 | (websocket-verify-client-headers 567 | (mapconcat 'identity (append (list http "" protocol extensions1 extensions2) 568 | all-required-headers) "\r\n")))) 569 | (should (websocket-verify-client-headers 570 | (mapconcat 'identity 571 | (mapcar 'upcase 572 | (append (list http "" protocol extensions1 extensions2) 573 | all-required-headers)) "\r\n"))) 574 | (dolist (header all-required-headers) 575 | (should-not (websocket-verify-client-headers 576 | (mapconcat 'identity (append (list http "") 577 | (remove header all-required-headers)) 578 | "\r\n")))) 579 | (should-not (websocket-verify-client-headers 580 | (mapconcat 'identity (append (list "HTTP/1.0" "") all-required-headers) 581 | "\r\n"))))) 582 | 583 | (ert-deftest websocket-intersect () 584 | (should (equal '(2) (websocket-intersect '(1 2) '(2 3)))) 585 | (should (equal nil (websocket-intersect '(1 2) '(3 4)))) 586 | (should (equal '(1 2) (websocket-intersect '(1 2) '(1 2))))) 587 | 588 | (ert-deftest websocket-get-server-response () 589 | (let ((ws (websocket-inner-create :conn t :url t :accept-string "key" 590 | :protocols '("spa" "spb") 591 | :extensions '("sea" "seb")))) 592 | (should (equal (concat 593 | "HTTP/1.1 101 Switching Protocols\r\n" 594 | "Upgrade: websocket\r\n" 595 | "Connection: Upgrade\r\n" 596 | "Sec-WebSocket-Accept: key\r\n\r\n") 597 | (websocket-get-server-response ws nil nil))) 598 | (should (string-match "Sec-Websocket-Protocol: spb\r\n" 599 | (websocket-get-server-response ws '("spb" "spc") nil))) 600 | (should-not (string-match "Sec-Websocket-Protocol:" 601 | (websocket-get-server-response ws '("spc") nil))) 602 | (let ((output (websocket-get-server-response ws '("spa" "spb") nil))) 603 | (should (string-match "Sec-Websocket-Protocol: spa\r\n" output)) 604 | (should (string-match "Sec-Websocket-Protocol: spb\r\n" output))) 605 | (should (string-match "Sec-Websocket-Extensions: sea" 606 | (websocket-get-server-response ws nil '("sea" "sec")))) 607 | (should-not (string-match "Sec-Websocket-Extensions:" 608 | (websocket-get-server-response ws nil '("sec")))) 609 | (let ((output (websocket-get-server-response ws nil '("sea" "seb")))) 610 | (should (string-match "Sec-Websocket-Extensions: sea\r\n" output)) 611 | (should (string-match "Sec-Websocket-Extensions: seb\r\n" output))))) 612 | 613 | (ert-deftest websocket-server-filter () 614 | (let ((on-open-called) 615 | (ws (websocket-inner-create :conn t :url t :accept-string "key" 616 | :on-open (lambda (ws) (setq on-open-called t)))) 617 | (closed) 618 | (response) 619 | (processed)) 620 | (cl-letf (((symbol-function 'process-send-string) (lambda (p text) (setq response text))) 621 | ((symbol-function 'websocket-close) (lambda (ws) (setq closed t))) 622 | ((symbol-function 'process-get) (lambda (process sym) ws))) 623 | ;; Bad request, in two parts 624 | (cl-letf (((symbol-function 'websocket-verify-client-headers) 625 | (lambda (text) nil))) 626 | (websocket-server-filter nil "HTTP/1.0 GET /foo \r\n") 627 | (should-not closed) 628 | (websocket-server-filter nil "\r\n") 629 | (should (equal response "HTTP/1.1 400 Bad Request\r\n\r\n")) 630 | (should-not (websocket-inflight-input ws))) 631 | ;; Good request, followed by packet 632 | (setq closed nil 633 | response nil) 634 | (setf (websocket-inflight-input ws) nil) 635 | (cl-letf (((symbol-function 'websocket-verify-client-headers) 636 | (lambda (text) t)) 637 | ((symbol-function 'websocket-get-server-response) 638 | (lambda (ws protocols extensions) 639 | "response")) 640 | ((symbol-function 'websocket-process-input-on-open-ws) 641 | (lambda (ws text) 642 | (setq processed t) 643 | (should 644 | (equal text websocket-test-hello))))) 645 | (websocket-server-filter nil 646 | (concat "\r\n\r\n" websocket-test-hello)) 647 | (should (equal (websocket-ready-state ws) 'open)) 648 | (should-not closed) 649 | (should (equal response "response")) 650 | (should processed))))) 651 | 652 | (ert-deftest websocket-complete-server-response-test () 653 | ;; Example taken from RFC 654 | (should (equal 655 | (concat "HTTP/1.1 101 Switching Protocols\r\n" 656 | "Upgrade: websocket\r\n" 657 | "Connection: Upgrade\r\n" 658 | "Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=\r\n" 659 | "Sec-WebSocket-Protocol: chat\r\n\r\n" 660 | ) 661 | (let ((header-info 662 | (websocket-verify-client-headers 663 | (concat "GET /chat HTTP/1.1\r\n" 664 | "Host: server.example.com\r\n" 665 | "Upgrade: websocket\r\n" 666 | "Connection: Upgrade\r\n" 667 | "Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n" 668 | "Sec-WebSocket-Protocol: chat, superchat\r\n" 669 | "Sec-WebSocket-Version: 13\r\n")))) 670 | (should header-info) 671 | (let ((ws (websocket-inner-create 672 | :conn t :url t 673 | :accept-string (websocket-calculate-accept 674 | (plist-get header-info :key)) 675 | :protocols '("chat")))) 676 | (websocket-get-server-response 677 | ws 678 | (plist-get header-info :protocols) 679 | (plist-get header-info :extension))))))) 680 | 681 | (ert-deftest websocket-server-close () 682 | (let ((websocket-server-websockets 683 | (list (websocket-inner-create :conn 'conn-a :url t :accept-string t 684 | :server-conn 'a 685 | :ready-state 'open) 686 | (websocket-inner-create :conn 'conn-b :url t :accept-string t 687 | :server-conn 'b 688 | :ready-state 'open) 689 | (websocket-inner-create :conn 'conn-c :url t :accept-string t 690 | :server-conn 'b 691 | :ready-state 'closed))) 692 | (deleted-processes) 693 | (closed-websockets)) 694 | (cl-letf (((symbol-function 'delete-process) 695 | (lambda (conn) (add-to-list 'deleted-processes conn))) 696 | ((symbol-function 'websocket-close) 697 | (lambda (ws) 698 | ;; we always remove on closing in the 699 | ;; actual code. 700 | (setq websocket-server-websockets 701 | (remove ws websocket-server-websockets)) 702 | (should-not (eq (websocket-ready-state ws) 'closed)) 703 | (add-to-list 'closed-websockets ws)))) 704 | (websocket-server-close 'b)) 705 | (should (equal deleted-processes '(b))) 706 | (should (eq 1 (length closed-websockets))) 707 | (should (eq 'conn-b (websocket-conn (car closed-websockets)))) 708 | (should (eq 1 (length websocket-server-websockets))) 709 | (should (eq 'conn-a (websocket-conn (car websocket-server-websockets)))))) 710 | 711 | (ert-deftest websocket-default-error-handler () 712 | (cl-letf (((symbol-function 'try-error) 713 | (lambda (callback-type err expected-message) 714 | (cl-flet ((display-warning 715 | (type message &optional level buffer-name) 716 | (should (eq type 'websocket)) 717 | (should (eq level :error)) 718 | (should (string= message expected-message)))) 719 | (websocket-default-error-handler nil 720 | callback-type 721 | err))))) 722 | (try-error 723 | 'on-message 724 | '(end-of-buffer) 725 | "in callback `on-message': End of buffer") 726 | 727 | (try-error 728 | 'on-close 729 | '(wrong-number-of-arguments 1 2) 730 | "in callback `on-close': Wrong number of arguments: 1, 2"))) 731 | -------------------------------------------------------------------------------- /websocket.el: -------------------------------------------------------------------------------- 1 | ;;; websocket.el --- Emacs WebSocket client and server -*- lexical-binding:t -*- 2 | 3 | ;; Copyright (c) 2013, 2016-2023 Free Software Foundation, Inc. 4 | 5 | ;; Author: Andrew Hyatt 6 | ;; Homepage: https://github.com/ahyatt/emacs-websocket 7 | ;; Keywords: Communication, Websocket, Server 8 | ;; Version: 1.15 9 | ;; Package-Requires: ((cl-lib "0.5")) 10 | ;; 11 | ;; This program is free software; you can redistribute it and/or 12 | ;; modify it under the terms of the GNU General Public License as 13 | ;; published by the Free Software Foundation; either version 2 of the 14 | ;; License, or (at your option) any later version. 15 | ;; 16 | ;; This program is distributed in the hope that it will be useful, but 17 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | ;; General Public License for more details. 20 | ;; 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with GNU Emacs. If not, see . 23 | 24 | ;;; Commentary: 25 | ;; This implements RFC 6455, which can be found at 26 | ;; http://tools.ietf.org/html/rfc6455. 27 | ;; 28 | ;; This library contains code to connect Emacs as a client to a 29 | ;; websocket server, and for Emacs to act as a server for websocket 30 | ;; connections. 31 | ;; 32 | ;; Websockets clients are created by calling `websocket-open', which 33 | ;; returns a `websocket' struct. Users of this library use the 34 | ;; websocket struct, and can call methods `websocket-send-text', which 35 | ;; sends text over the websocket, or `websocket-send', which sends a 36 | ;; `websocket-frame' struct, enabling finer control of what is sent. 37 | ;; A callback is passed to `websocket-open' that will retrieve 38 | ;; websocket frames called from the websocket. Websockets are 39 | ;; eventually closed with `websocket-close'. 40 | ;; 41 | ;; Server functionality is similar. A server is started with 42 | ;; `websocket-server' called with a port and the callbacks to use, 43 | ;; which returns a process. The process can later be closed with 44 | ;; `websocket-server-close'. A `websocket' struct is also created 45 | ;; for every connection, and is exposed through the callbacks. 46 | 47 | (require 'bindat) 48 | (require 'url-parse) 49 | (require 'url-cookie) 50 | (require 'seq) 51 | (eval-when-compile (require 'cl-lib)) 52 | 53 | ;;; Code: 54 | 55 | (cl-defstruct (websocket 56 | (:constructor nil) 57 | (:constructor websocket-inner-create)) 58 | "A websocket structure. 59 | This follows the W3C Websocket API, except translated to elisp 60 | idioms. The API is implemented in both the websocket struct and 61 | additional methods. Due to how defstruct slots are accessed, all 62 | API methods are prefixed with \"websocket-\" and take a websocket 63 | as an argument, so the distrinction between the struct API and 64 | the additional helper APIs are not visible to the caller. 65 | 66 | A websocket struct is created with `websocket-open'. 67 | 68 | `ready-state' contains one of `connecting', `open', or 69 | `closed', depending on the state of the websocket. 70 | 71 | The W3C API \"bufferedAmount\" call is not currently implemented, 72 | since there is no elisp API to get the buffered amount from the 73 | subprocess. There may, in fact, be output data buffered, 74 | however, when the `on-message' or `on-close' callbacks are 75 | called. 76 | 77 | `on-open', `on-message', `on-close', and `on-error' are described 78 | in `websocket-open'. 79 | 80 | The `negotiated-extensions' slot lists the extensions accepted by 81 | both the client and server, and `negotiated-protocols' does the 82 | same for the protocols." 83 | ;; API 84 | (ready-state 'connecting) 85 | client-data 86 | on-open 87 | on-message 88 | on-close 89 | on-error 90 | negotiated-protocols 91 | negotiated-extensions 92 | (server-p nil :read-only t) 93 | 94 | ;; Other data - clients should not have to access this. 95 | (url (cl-assert nil) :read-only t) 96 | (protocols nil :read-only t) 97 | (extensions nil :read-only t) 98 | (conn (cl-assert nil) :read-only t) 99 | ;; Only populated for servers, this is the server connection. 100 | server-conn 101 | origin 102 | accept-string 103 | (inflight-input nil)) 104 | 105 | (defvar websocket-version "1.12" 106 | "Version numbers of this version of websocket.el.") 107 | 108 | (defvar websocket-debug nil 109 | "Set to true to output debugging info to a per-websocket buffer. 110 | The buffer is ` *websocket URL debug*' where URL is the 111 | URL of the connection.") 112 | 113 | (defconst websocket-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" 114 | "The websocket GUID as defined in RFC 6455. 115 | Do not change unless the RFC changes.") 116 | 117 | (defvar websocket-callback-debug-on-error nil 118 | "If true, when an error happens in a client callback, invoke the debugger. 119 | Having this on can cause issues with missing frames if the debugger is 120 | exited by quitting instead of continuing, so it's best to have this set 121 | to nil unless it is especially needed.") 122 | 123 | (defmacro websocket-document-function (function docstring) 124 | "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc." 125 | (declare (indent defun) 126 | (doc-string 2)) 127 | `(put ',function 'function-documentation ,docstring)) 128 | 129 | (websocket-document-function websocket-on-open 130 | "Accessor for websocket on-open callback. 131 | See `websocket-open' for details. 132 | 133 | \(fn WEBSOCKET)") 134 | 135 | (websocket-document-function websocket-on-message 136 | "Accessor for websocket on-message callback. 137 | See `websocket-open' for details. 138 | 139 | \(fn WEBSOCKET)") 140 | 141 | (websocket-document-function websocket-on-close 142 | "Accessor for websocket on-close callback. 143 | See `websocket-open' for details. 144 | 145 | \(fn WEBSOCKET)") 146 | 147 | (websocket-document-function websocket-on-error 148 | "Accessor for websocket on-error callback. 149 | See `websocket-open' for details. 150 | 151 | \(fn WEBSOCKET)") 152 | 153 | (defun websocket-genbytes (nbytes) 154 | "Generate NBYTES random bytes." 155 | (let ((s (make-string nbytes ?\s))) 156 | (dotimes (i nbytes) 157 | (aset s i (random 256))) 158 | s)) 159 | 160 | (defun websocket-try-callback (websocket-callback callback-type websocket 161 | &rest rest) 162 | "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args. 163 | If an error happens, it is handled according to 164 | `websocket-callback-debug-on-error'." 165 | ;; This looks like it should be able to done more efficiently, but 166 | ;; I'm not sure that's the case. We can't do it as a macro, since 167 | ;; we want it to change whenever websocket-callback-debug-on-error 168 | ;; changes. 169 | (let ((args rest) 170 | (debug-on-error websocket-callback-debug-on-error)) 171 | (push websocket args) 172 | (if websocket-callback-debug-on-error 173 | (condition-case err 174 | (apply (funcall websocket-callback websocket) args) 175 | ((debug error) (funcall (websocket-on-error websocket) 176 | websocket callback-type err))) 177 | (condition-case err 178 | (apply (funcall websocket-callback websocket) args) 179 | (error (funcall (websocket-on-error websocket) websocket 180 | callback-type err)))))) 181 | 182 | (defun websocket-genkey () 183 | "Generate a key suitable for the websocket handshake." 184 | (base64-encode-string (websocket-genbytes 16))) 185 | 186 | (defun websocket-calculate-accept (key) 187 | "Calculate the expect value of the accept header. 188 | This is based on the KEY from the Sec-WebSocket-Key header." 189 | (base64-encode-string 190 | (sha1 (concat key websocket-guid) nil nil t))) 191 | 192 | (defun websocket-get-bytes (s n) 193 | "From string S, retrieve the value of N bytes. 194 | Return the value as an unsigned integer. The value N must be a 195 | power of 2, up to 8. 196 | 197 | We support getting frames up to 536870911 bytes (2^29 - 1), 198 | approximately 537M long." 199 | (if (= n 8) 200 | (let* ((32-bit-parts 201 | (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val)) 202 | (cval 203 | (logior (ash (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1)))) 204 | (if (and (= (aref 32-bit-parts 0) 0) 205 | (= (ash (aref 32-bit-parts 1) -29) 0)) 206 | cval 207 | (signal 'websocket-unparseable-frame 208 | (list "Frame value found too large to parse!")))) 209 | ;; n is not 8 210 | (bindat-get-field 211 | (condition-case _ 212 | (bindat-unpack 213 | `((:val 214 | ,(cond ((= n 1) 'u8) 215 | ((= n 2) 'u16) 216 | ((= n 4) 'u32) 217 | ;; This is an error with the library, 218 | ;; not a user-facing, meaningful error. 219 | (t (error 220 | "websocket-get-bytes: Unknown N: %S" n))))) 221 | s) 222 | (args-out-of-range (signal 'websocket-unparseable-frame 223 | (list (format "Frame unexpectedly short: %s" s))))) 224 | :val))) 225 | 226 | (defun websocket-to-bytes (val nbytes) 227 | "Encode the integer VAL in NBYTES of data. 228 | NBYTES much be a power of 2, up to 8. 229 | 230 | This supports encoding values up to 536870911 bytes (2^29 - 1), 231 | approximately 537M long." 232 | (when (and (< nbytes 8) 233 | (> val (expt 2 (* 8 nbytes)))) 234 | ;; not a user-facing error, this must be caused from an error in 235 | ;; this library 236 | (error "websocket-to-bytes: Value %d could not be expressed in %d bytes" 237 | val nbytes)) 238 | (if (= nbytes 8) 239 | (progn 240 | (let* ((hi-32bits (ash val -32)) 241 | ;; This is just VAL on systems that don't have >= 32 bits. 242 | (low-32bits (- val (ash hi-32bits 32)))) 243 | (when (or (> hi-32bits 0) (> (ash low-32bits -29) 0)) 244 | (signal 'websocket-frame-too-large (list val))) 245 | (bindat-pack `((:val vec 2 u32)) 246 | `((:val . [,hi-32bits ,low-32bits]))))) 247 | (bindat-pack 248 | `((:val ,(cond ((= nbytes 1) 'u8) 249 | ((= nbytes 2) 'u16) 250 | ((= nbytes 4) 'u32) 251 | ;; Library error, not system error 252 | (t (error "websocket-to-bytes: Unknown NBYTES: %S" nbytes))))) 253 | `((:val . ,val))))) 254 | 255 | (defun websocket-get-opcode (s) 256 | "Retrieve the opcode from first byte of string S." 257 | (websocket-ensure-length s 1) 258 | (let ((opcode (logand #xf (aref s 0)))) 259 | (cond ((= opcode 0) 'continuation) 260 | ((= opcode 1) 'text) 261 | ((= opcode 2) 'binary) 262 | ((= opcode 8) 'close) 263 | ((= opcode 9) 'ping) 264 | ((= opcode 10) 'pong)))) 265 | 266 | (defun websocket-get-payload-len (s) 267 | "Parse out the payload length from the string S. 268 | We start at position 0, and return a cons of the payload length and how 269 | many bytes were consumed from the string." 270 | (websocket-ensure-length s 1) 271 | (let* ((initial-val (logand 127 (aref s 0)))) 272 | (cond ((= initial-val 127) 273 | (websocket-ensure-length s 9) 274 | (cons (websocket-get-bytes (substring s 1) 8) 9)) 275 | ((= initial-val 126) 276 | (websocket-ensure-length s 3) 277 | (cons (websocket-get-bytes (substring s 1) 2) 3)) 278 | (t (cons initial-val 1))))) 279 | 280 | (cl-defstruct websocket-frame opcode payload length completep) 281 | 282 | (defun websocket-frame-text (frame) 283 | "Given FRAME, return the payload as a utf-8 encoded string." 284 | (cl-assert (websocket-frame-p frame)) 285 | (decode-coding-string (websocket-frame-payload frame) 'utf-8)) 286 | 287 | (defun websocket-mask (key data) 288 | "Using string KEY, mask string DATA according to the RFC. 289 | This is used to both mask and unmask data." 290 | ;; Returning the string as unibyte is important here. Because we set the 291 | ;; string byte by byte, this results in a unibyte string. 292 | (cl-loop 293 | with result = (make-string (length data) ?x) 294 | for i from 0 below (length data) 295 | do (setf (seq-elt result i) (logxor (aref key (mod i 4)) (seq-elt data i))) 296 | finally return result)) 297 | 298 | (defun websocket-ensure-length (s n) 299 | "Ensure the string S has at most N bytes. 300 | Otherwise we throw the error `websocket-incomplete-frame'." 301 | (when (< (length s) n) 302 | (throw 'websocket-incomplete-frame nil))) 303 | 304 | (defun websocket-encode-frame (frame should-mask) 305 | "Encode the FRAME struct to the binary representation. 306 | We mask the frame or not, depending on SHOULD-MASK." 307 | (let* ((opcode (websocket-frame-opcode frame)) 308 | (payload (websocket-frame-payload frame)) 309 | (fin (websocket-frame-completep frame)) 310 | (payloadp (and payload 311 | (memq opcode '(continuation ping pong text binary)))) 312 | (mask-key (when should-mask (websocket-genbytes 4)))) 313 | (apply #'unibyte-string 314 | (let ((val (append (list 315 | (logior (pcase opcode 316 | (`continuation 0) 317 | (`text 1) 318 | (`binary 2) 319 | (`close 8) 320 | (`ping 9) 321 | (`pong 10)) 322 | (if fin 128 0))) 323 | (when payloadp 324 | (list 325 | (logior 326 | (if should-mask 128 0) 327 | (cond ((< (length payload) 126) (length payload)) 328 | ((< (length payload) 65536) 126) 329 | (t 127))))) 330 | (when (and payloadp (>= (length payload) 126)) 331 | (append (websocket-to-bytes 332 | (length payload) 333 | (cond ((< (length payload) 126) 1) 334 | ((< (length payload) 65536) 2) 335 | (t 8))) nil)) 336 | (when (and payloadp should-mask) 337 | (append mask-key nil)) 338 | (when payloadp 339 | (append (if should-mask (websocket-mask mask-key payload) 340 | payload) 341 | nil))))) 342 | ;; We have to make sure the non-payload data is a full 32-bit frame 343 | (if (= 1 (length val)) 344 | (append val '(0)) val))))) 345 | 346 | (defun websocket-read-frame (s) 347 | "Read from string S a `websocket-frame' struct with the contents. 348 | This only gets complete frames. Partial frames need to wait until 349 | the frame finishes. If the frame is not completed, return NIL." 350 | (catch 'websocket-incomplete-frame 351 | (websocket-ensure-length s 1) 352 | (let* ((opcode (websocket-get-opcode s)) 353 | (fin (logand 128 (aref s 0))) 354 | (payloadp (memq opcode '(continuation text binary ping pong))) 355 | (payload-len (when payloadp 356 | (websocket-get-payload-len (substring s 1)))) 357 | (maskp (and 358 | payloadp 359 | (= 128 (logand 128 (aref s 1))))) 360 | (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len)))) 361 | (payload-end (when payloadp (+ payload-start (car payload-len)))) 362 | (unmasked-payload (when payloadp 363 | (websocket-ensure-length s payload-end) 364 | (substring s payload-start payload-end)))) 365 | (make-websocket-frame 366 | :opcode opcode 367 | :payload 368 | (if maskp 369 | (let ((masking-key (substring s (+ 1 (cdr payload-len)) 370 | (+ 5 (cdr payload-len))))) 371 | (websocket-mask masking-key unmasked-payload)) 372 | unmasked-payload) 373 | :length (if payloadp payload-end 1) 374 | :completep (> fin 0))))) 375 | 376 | (defun websocket-format-error (err) 377 | "Format an error message like command level does. 378 | ERR should be a cons of error symbol and error data." 379 | 380 | ;; Formatting code adapted from `edebug-report-error' 381 | (concat (or (get (car err) 'error-message) 382 | (format "peculiar error (%s)" (car err))) 383 | (when (cdr err) 384 | (format ": %s" 385 | (mapconcat #'prin1-to-string 386 | (cdr err) ", "))))) 387 | 388 | (defun websocket-default-error-handler (_websocket type err) 389 | "The default error handler used to handle errors in callbacks." 390 | (display-warning 'websocket 391 | (format "in callback `%S': %s" 392 | type 393 | (websocket-format-error err)) 394 | :error)) 395 | 396 | ;; Error symbols in use by the library 397 | (put 'websocket-unsupported-protocol 'error-conditions 398 | '(error websocket-error websocket-unsupported-protocol)) 399 | (put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol") 400 | (put 'websocket-wss-needs-emacs-24 'error-conditions 401 | '(error websocket-error websocket-unsupported-protocol 402 | websocket-wss-needs-emacs-24)) 403 | (put 'websocket-wss-needs-emacs-24 'error-message 404 | "wss protocol is not supported for Emacs before version 24.") 405 | (put 'websocket-received-error-http-response 'error-conditions 406 | '(error websocket-error websocket-received-error-http-response)) 407 | (put 'websocket-received-error-http-response 'error-message 408 | "Error response received from websocket server") 409 | (put 'websocket-invalid-header 'error-conditions 410 | '(error websocket-error websocket-invalid-header)) 411 | (put 'websocket-invalid-header 'error-message 412 | "Invalid HTTP header sent") 413 | (put 'websocket-illegal-frame 'error-conditions 414 | '(error websocket-error websocket-illegal-frame)) 415 | (put 'websocket-illegal-frame 'error-message 416 | "Cannot send illegal frame to websocket") 417 | (put 'websocket-closed 'error-conditions 418 | '(error websocket-error websocket-closed)) 419 | (put 'websocket-closed 'error-message 420 | "Cannot send message to a closed websocket") 421 | (put 'websocket-unparseable-frame 'error-conditions 422 | '(error websocket-error websocket-unparseable-frame)) 423 | (put 'websocket-unparseable-frame 'error-message 424 | "Received an unparseable frame") 425 | (put 'websocket-frame-too-large 'error-conditions 426 | '(error websocket-error websocket-frame-too-large)) 427 | (put 'websocket-frame-too-large 'error-message 428 | "The frame being sent is too large for this emacs to handle") 429 | 430 | (defun websocket-intersect (a b) 431 | "Simple list intersection, should function like Common Lisp's `intersection'." 432 | (let ((result)) 433 | (dolist (elem a (nreverse result)) 434 | (when (member elem b) 435 | (push elem result))))) 436 | 437 | (defun websocket-get-debug-buffer-create (websocket) 438 | "Get or create the buffer corresponding to WEBSOCKET." 439 | (let ((buf (get-buffer-create (format "*websocket %s debug*" 440 | (websocket-url websocket))))) 441 | (when (= 0 (buffer-size buf)) 442 | (buffer-disable-undo buf)) 443 | buf)) 444 | 445 | (defun websocket-debug (websocket msg &rest args) 446 | "In the WEBSOCKET's debug buffer, send MSG, with format ARGS." 447 | (when websocket-debug 448 | (let ((buf (websocket-get-debug-buffer-create websocket))) 449 | (save-excursion 450 | (with-current-buffer buf 451 | (goto-char (point-max)) 452 | (insert "[WS] ") 453 | (insert (apply #'format (append (list msg) args))) 454 | (insert "\n")))))) 455 | 456 | (defun websocket-verify-response-code (output) 457 | "Verify that OUTPUT contains a valid HTTP response code. 458 | The only acceptable one to websocket is responce code 101. 459 | A t value will be returned on success, and an error thrown 460 | if not." 461 | (unless (string-match "^HTTP/1.1 \\([[:digit:]]+\\)" output) 462 | (signal 'websocket-invalid-header (list "Invalid HTTP status line"))) 463 | (unless (equal "101" (match-string 1 output)) 464 | (signal 'websocket-received-error-http-response 465 | (list (string-to-number (match-string 1 output))))) 466 | t) 467 | 468 | (defun websocket-parse-repeated-field (output field) 469 | "From header-containing OUTPUT, parse out the list from a 470 | possibly repeated field." 471 | (let ((pos 0) 472 | (extensions)) 473 | (while (and pos 474 | (string-match (format "\r\n%s: \\(.*\\)\r\n" field) 475 | output pos)) 476 | (when (setq pos (match-end 1)) 477 | (setq extensions (append extensions (split-string 478 | (match-string 1 output) ", ?"))))) 479 | extensions)) 480 | 481 | (defun websocket-process-frame (websocket frame) 482 | "Using the WEBSOCKET's filter and connection, process the FRAME. 483 | This returns a lambda that should be executed when all frames have 484 | been processed. If the frame has a payload, the lambda has the frame 485 | passed to the filter slot of WEBSOCKET. If the frame is a ping, 486 | the lambda has a reply with a pong. If the frame is a close, the lambda 487 | has connection termination." 488 | (let ((opcode (websocket-frame-opcode frame))) 489 | (cond ((memq opcode '(continuation text binary)) 490 | (lambda () (websocket-try-callback 'websocket-on-message 'on-message 491 | websocket frame))) 492 | ((eq opcode 'ping) 493 | (lambda () (websocket-send websocket 494 | (make-websocket-frame 495 | :opcode 'pong 496 | :payload (websocket-frame-payload frame) 497 | :completep t)))) 498 | ((eq opcode 'close) 499 | (lambda () (delete-process (websocket-conn websocket)))) 500 | (t (lambda ()))))) 501 | 502 | (defun websocket-process-input-on-open-ws (websocket text) 503 | "This handles input processing for both the client and server filters." 504 | (let ((current-frame) 505 | (processing-queue) 506 | (start-point 0)) 507 | (while (setq current-frame (websocket-read-frame 508 | (substring text start-point))) 509 | (push (websocket-process-frame websocket current-frame) processing-queue) 510 | (cl-incf start-point (websocket-frame-length current-frame))) 511 | (when (> (length text) start-point) 512 | (setf (websocket-inflight-input websocket) 513 | (substring text start-point))) 514 | (dolist (to-process (nreverse processing-queue)) 515 | (funcall to-process)))) 516 | 517 | (defun websocket-send-text (websocket text) 518 | "To the WEBSOCKET, send TEXT as a complete frame." 519 | (websocket-send 520 | websocket 521 | (make-websocket-frame :opcode 'text 522 | :payload (encode-coding-string 523 | text 'raw-text) 524 | :completep t))) 525 | 526 | (defun websocket-check (frame) 527 | "Check FRAME for correctness, returning true if correct." 528 | (or 529 | ;; Text, binary, and continuation frames need payloads 530 | (and (memq (websocket-frame-opcode frame) '(text binary continuation)) 531 | (websocket-frame-payload frame)) 532 | ;; Pings and pongs may optionally have them 533 | (memq (websocket-frame-opcode frame) '(ping pong)) 534 | ;; And close shouldn't have any payload, and should always be complete. 535 | (and (eq (websocket-frame-opcode frame) 'close) 536 | (not (websocket-frame-payload frame)) 537 | (websocket-frame-completep frame)))) 538 | 539 | (defun websocket-send (websocket frame) 540 | "To the WEBSOCKET server, send the FRAME. 541 | This will raise an error if the frame is illegal. 542 | 543 | The error signaled may be of type `websocket-illegal-frame' if 544 | the frame is malformed in some way, also having the condition 545 | type of `websocket-error'. The data associated with the signal 546 | is the frame being sent. 547 | 548 | If the websocket is closed a signal `websocket-closed' is sent, 549 | also with `websocket-error' condition. The data in the signal is 550 | also the frame. 551 | 552 | The frame may be too large for this buid of Emacs, in which case 553 | `websocket-frame-too-large' is returned, with the data of the 554 | size of the frame which was too large to process. This also has 555 | the `websocket-error' condition." 556 | (unless (websocket-check frame) 557 | (signal 'websocket-illegal-frame (list frame))) 558 | (websocket-debug websocket "Sending frame, opcode: %s payload: %s" 559 | (websocket-frame-opcode frame) 560 | (websocket-frame-payload frame)) 561 | (unless (websocket-openp websocket) 562 | (signal 'websocket-closed (list frame))) 563 | (process-send-string (websocket-conn websocket) 564 | ;; We mask only when we're a client, following the spec. 565 | (websocket-encode-frame frame (not (websocket-server-p websocket))))) 566 | 567 | (defun websocket-openp (websocket) 568 | "Check WEBSOCKET and return non-nil if the connection is open." 569 | (and websocket 570 | (not (eq 'close (websocket-ready-state websocket))) 571 | (member (process-status (websocket-conn websocket)) '(open run)))) 572 | 573 | (defun websocket-close (websocket) 574 | "Close WEBSOCKET and erase all the old websocket data." 575 | (websocket-debug websocket "Closing websocket") 576 | (websocket-try-callback 'websocket-on-close 'on-close websocket) 577 | (when (websocket-openp websocket) 578 | (websocket-send websocket 579 | (make-websocket-frame :opcode 'close 580 | :completep t)) 581 | (setf (websocket-ready-state websocket) 'closed)) 582 | (delete-process (websocket-conn websocket))) 583 | 584 | ;;;;;;;;;;;;;;;;;;;;;; 585 | ;; Websocket client ;; 586 | ;;;;;;;;;;;;;;;;;;;;;; 587 | 588 | (cl-defun websocket-open (url &key protocols extensions (on-open 'identity) 589 | (on-message (lambda (_w _f))) (on-close 'identity) 590 | (on-error 'websocket-default-error-handler) 591 | (nowait nil) (custom-header-alist nil)) 592 | "Open a websocket connection to URL, returning the `websocket' struct. 593 | The PROTOCOL argument is optional, and setting it will declare to 594 | the server that this client supports the protocols in the list 595 | given. We will require that the server also has to support that 596 | protocols. 597 | 598 | Similar logic applies to EXTENSIONS, which is a list of conses, 599 | the car of which is a string naming the extension, and the cdr of 600 | which is the list of parameter strings to use for that extension. 601 | The parameter strings are of the form \"key=value\" or \"value\". 602 | EXTENSIONS can be NIL if none are in use. An example value would 603 | be (\"deflate-stream\" . (\"mux\" \"max-channels=4\")). 604 | 605 | Cookies that are set via `url-cookie-store' will be used during 606 | communication with the server, and cookies received from the 607 | server will be stored in the same cookie storage that the 608 | `url-cookie' package uses. 609 | 610 | Optionally you can specify 611 | ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well. 612 | 613 | The ON-OPEN callback is called after the connection is 614 | established with the websocket as the only argument. The return 615 | value is unused. 616 | 617 | The ON-MESSAGE callback is called after receiving a frame, and is 618 | called with the websocket as the first argument and 619 | `websocket-frame' struct as the second. The return value is 620 | unused. 621 | 622 | The ON-CLOSE callback is called after the connection is closed, or 623 | failed to open. It is called with the websocket as the only 624 | argument, and the return value is unused. 625 | 626 | The ON-ERROR callback is called when any of the other callbacks 627 | have an error. It takes the websocket as the first argument, and 628 | a symbol as the second argument either `on-open', `on-message', 629 | or `on-close', and the error as the third argument. Do NOT 630 | rethrow the error, or else you may miss some websocket messages. 631 | You similarly must not generate any other errors in this method. 632 | If you want to debug errors, set 633 | `websocket-callback-debug-on-error' to t, but this also can be 634 | dangerous is the debugger is quit out of. If not specified, 635 | `websocket-default-error-handler' is used. 636 | 637 | For each of these event handlers, the client code can store 638 | arbitrary data in the `client-data' slot in the returned 639 | websocket. 640 | 641 | The following errors might be thrown in this method or in 642 | websocket processing, all of them having the error-condition 643 | `websocket-error' in addition to their own symbol: 644 | 645 | `websocket-unsupported-protocol': Data in the error signal is the 646 | protocol that is unsupported. For example, giving a URL starting 647 | with http by mistake raises this error. 648 | 649 | `websocket-wss-needs-emacs-24': Trying to connect wss protocol 650 | using Emacs < 24 raises this error. You can catch this error 651 | also by `websocket-unsupported-protocol'. 652 | 653 | `websocket-received-error-http-response': Data in the error 654 | signal is the integer error number. 655 | 656 | `websocket-invalid-header': Data in the error is a string 657 | describing the invalid header received from the server. 658 | 659 | `websocket-unparseable-frame': Data in the error is a string 660 | describing the problem with the frame. 661 | 662 | `nowait': If NOWAIT is true, return without waiting for the 663 | connection to complete. 664 | 665 | `custom-headers-alist': An alist of custom headers to pass to the 666 | server. The car is the header name, the cdr is the header value. 667 | These are different from the extensions because it is not related 668 | to the websocket protocol. 669 | " 670 | (let* ((name (format "websocket to %s" url)) 671 | (url-struct (url-generic-parse-url url)) 672 | (key (websocket-genkey)) 673 | (coding-system-for-read 'binary) 674 | (coding-system-for-write 'binary) 675 | (conn (if (member (url-type url-struct) '("ws" "wss")) 676 | (let* ((type (if (equal (url-type url-struct) "ws") 677 | 'plain 'tls)) 678 | (port (if (= 0 (url-port url-struct)) 679 | (if (eq type 'tls) 443 80) 680 | (url-port url-struct))) 681 | (host (url-host url-struct))) 682 | (if (eq type 'plain) 683 | (make-network-process :name name :buffer nil :host host 684 | :service port :nowait nowait) 685 | (condition-case-unless-debug nil 686 | (open-network-stream name nil host port :type type :nowait nowait) 687 | (wrong-number-of-arguments 688 | (signal 'websocket-wss-needs-emacs-24 (list "wss")))))) 689 | (signal 'websocket-unsupported-protocol (list (url-type url-struct))))) 690 | (websocket (websocket-inner-create 691 | :conn conn 692 | :url url 693 | :on-open on-open 694 | :on-message on-message 695 | :on-close on-close 696 | :on-error on-error 697 | :protocols protocols 698 | :extensions (mapcar 'car extensions) 699 | :accept-string 700 | (websocket-calculate-accept key)))) 701 | (unless conn (error "Could not establish the websocket connection to %s" url)) 702 | (process-put conn :websocket websocket) 703 | (set-process-filter conn 704 | (lambda (process output) 705 | (let ((websocket (process-get process :websocket))) 706 | (websocket-outer-filter websocket output)))) 707 | (set-process-sentinel 708 | conn 709 | (websocket-sentinel url conn key protocols extensions custom-header-alist nowait)) 710 | (set-process-query-on-exit-flag conn nil) 711 | (websocket-ensure-handshake url conn key protocols extensions custom-header-alist nowait) 712 | websocket)) 713 | 714 | (defun websocket-sentinel (url conn key protocols extensions custom-header-alist nowait) 715 | #'(lambda (process change) 716 | (let ((websocket (process-get process :websocket))) 717 | (websocket-debug websocket "State change to %s" change) 718 | (let ((status (process-status process))) 719 | (when (and nowait (eq status 'open)) 720 | (websocket-ensure-handshake url conn key protocols extensions custom-header-alist nowait)) 721 | 722 | (when (and (member status '(closed failed exit signal)) 723 | (not (eq 'closed (websocket-ready-state websocket)))) 724 | (setf (websocket-ready-state websocket) 'closed) 725 | (websocket-try-callback 'websocket-on-close 'on-close websocket)))))) 726 | 727 | (defun websocket-ensure-handshake (url conn key protocols extensions custom-header-alist nowait) 728 | (let ((url-struct (url-generic-parse-url url)) 729 | (websocket (process-get conn :websocket))) 730 | (when (and (eq 'connecting (websocket-ready-state websocket)) 731 | (memq (process-status conn) 732 | (list 'run (if nowait 'connect 'open)))) 733 | (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s" 734 | key (websocket-accept-string websocket)) 735 | (process-send-string conn 736 | (format "GET %s HTTP/1.1\r\n%s" 737 | (let ((path (url-filename url-struct))) 738 | (if (> (length path) 0) path "/")) 739 | (websocket-create-headers 740 | url key protocols extensions custom-header-alist)))))) 741 | 742 | (defun websocket-process-headers (url headers) 743 | "On opening URL, process the HEADERS sent from the server." 744 | (when (string-match "Set-Cookie: \(.*\)\r\n" headers) 745 | ;; The url-current-object is assumed to be set by 746 | ;; url-cookie-handle-set-cookie. 747 | (let ((url-current-object (url-generic-parse-url url))) 748 | (url-cookie-handle-set-cookie (match-string 1 headers))))) 749 | 750 | (defun websocket-outer-filter (websocket output) 751 | "Filter the WEBSOCKET server's OUTPUT. 752 | This will parse headers and process frames repeatedly until there 753 | is no more output or the connection closes. If the websocket 754 | connection is invalid, the connection will be closed." 755 | (websocket-debug websocket "Received: %s" output) 756 | (let ((start-point) 757 | (text (concat (websocket-inflight-input websocket) output)) 758 | (header-end-pos)) 759 | (setf (websocket-inflight-input websocket) nil) 760 | ;; If we've received the complete header, check to see if we've 761 | ;; received the desired handshake. 762 | (when (and (eq 'connecting (websocket-ready-state websocket))) 763 | (if (and (setq header-end-pos (string-match "\r\n\r\n" text)) 764 | (setq start-point (+ 4 header-end-pos))) 765 | (progn 766 | (condition-case err 767 | (progn 768 | (websocket-verify-response-code text) 769 | (websocket-verify-headers websocket text) 770 | (websocket-process-headers (websocket-url websocket) text)) 771 | (error 772 | (websocket-close websocket) 773 | (funcall (websocket-on-error websocket) 774 | websocket 'on-open err))) 775 | (setf (websocket-ready-state websocket) 'open) 776 | (websocket-try-callback 'websocket-on-open 'on-open websocket)) 777 | (setf (websocket-inflight-input websocket) text))) 778 | (when (eq 'open (websocket-ready-state websocket)) 779 | (websocket-process-input-on-open-ws 780 | websocket (substring text (or start-point 0)))))) 781 | 782 | (defun websocket-verify-headers (websocket output) 783 | "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid. 784 | The output is assumed to have complete headers. This function 785 | will either return t or call `error'. This has the side-effect 786 | of populating the list of server extensions to WEBSOCKET." 787 | (let ((accept-regexp 788 | (concat "Sec-Web[Ss]ocket-Accept: " (regexp-quote (websocket-accept-string websocket))))) 789 | (websocket-debug websocket "Checking for accept header regexp: %s" accept-regexp) 790 | (unless (string-match accept-regexp output) 791 | (signal 'websocket-invalid-header 792 | (list "Incorrect handshake from websocket: is this really a websocket connection?")))) 793 | (let ((case-fold-search t)) 794 | (websocket-debug websocket "Checking for upgrade header") 795 | (unless (string-match "\r\nUpgrade: websocket\r\n" output) 796 | (signal 'websocket-invalid-header 797 | (list "No 'Upgrade: websocket' header found"))) 798 | (websocket-debug websocket "Checking for connection header") 799 | (unless (string-match "\r\nConnection: upgrade\r\n" output) 800 | (signal 'websocket-invalid-header 801 | (list "No 'Connection: upgrade' header found"))) 802 | (when (websocket-protocols websocket) 803 | (dolist (protocol (websocket-protocols websocket)) 804 | (websocket-debug websocket "Checking for protocol match: %s" 805 | protocol) 806 | (let ((protocols 807 | (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n" 808 | protocol) 809 | output) 810 | (list protocol) 811 | (signal 'websocket-invalid-header 812 | (list "Incorrect or missing protocol returned by the server."))))) 813 | (setf (websocket-negotiated-protocols websocket) protocols)))) 814 | (let* ((extensions (websocket-parse-repeated-field 815 | output 816 | "Sec-WebSocket-Extensions")) 817 | (extra-extensions)) 818 | (dolist (ext extensions) 819 | (let ((x (cl-first (split-string ext "; ?")))) 820 | (unless (or (member x (websocket-extensions websocket)) 821 | (member x extra-extensions)) 822 | (push x extra-extensions)))) 823 | (when extra-extensions 824 | (signal 'websocket-invalid-header 825 | (list (format "Non-requested extensions returned by server: %S" 826 | extra-extensions)))) 827 | (setf (websocket-negotiated-extensions websocket) extensions))) 828 | t) 829 | 830 | ;;;;;;;;;;;;;;;;;;;;;; 831 | ;; Websocket server ;; 832 | ;;;;;;;;;;;;;;;;;;;;;; 833 | 834 | (defvar websocket-server-websockets nil 835 | "A list of current websockets live on any server.") 836 | 837 | (cl-defun websocket-server (port &rest plist) 838 | "Open a websocket server on PORT. 839 | If the plist contains a `:host' HOST pair, this value will be 840 | used to configure the addresses the socket listens on. The symbol 841 | `local' specifies the local host. If unspecified or nil, the 842 | socket will listen on all addresses. 843 | 844 | This also takes a plist of callbacks: `:on-open', `:on-message', 845 | `:on-close' and `:on-error', which operate exactly as documented 846 | in the websocket client function `websocket-open'. Returns the 847 | connection, which should be kept in order to pass to 848 | `websocket-server-close'." 849 | (let* ((conn (make-network-process 850 | :name (format "websocket server on port %s" port) 851 | :server t 852 | :family 'ipv4 853 | :noquery t 854 | :filter 'websocket-server-filter 855 | :log 'websocket-server-accept 856 | :filter-multibyte nil 857 | :plist plist 858 | :host (plist-get plist :host) 859 | :service port))) 860 | conn)) 861 | 862 | (defun websocket-server-close (conn) 863 | "Closes the websocket, as well as all open websockets for this server." 864 | (let ((to-delete)) 865 | (dolist (ws websocket-server-websockets) 866 | (when (eq (websocket-server-conn ws) conn) 867 | (if (eq (websocket-ready-state ws) 'closed) 868 | (unless (member ws to-delete) 869 | (push ws to-delete)) 870 | (websocket-close ws)))) 871 | (dolist (ws to-delete) 872 | (setq websocket-server-websockets (remove ws websocket-server-websockets)))) 873 | (delete-process conn)) 874 | 875 | (defun websocket-server-accept (server client _message) 876 | "Accept a new websocket connection from a client." 877 | (let ((ws (websocket-inner-create 878 | :server-conn server 879 | :conn client 880 | :url client 881 | :server-p t 882 | :on-open (or (process-get server :on-open) 'identity) 883 | :on-message (or (process-get server :on-message) (lambda (_ws _frame))) 884 | :on-close (let ((user-method 885 | (or (process-get server :on-close) 'identity))) 886 | (lambda (ws) 887 | (setq websocket-server-websockets 888 | (remove ws websocket-server-websockets)) 889 | (funcall user-method ws))) 890 | :on-error (or (process-get server :on-error) 891 | 'websocket-default-error-handler) 892 | :protocols (process-get server :protocol) 893 | :extensions (mapcar 'car (process-get server :extensions))))) 894 | (unless (member ws websocket-server-websockets) 895 | (push ws websocket-server-websockets)) 896 | (process-put client :websocket ws) 897 | (set-process-coding-system client 'binary 'binary) 898 | (set-process-sentinel client 899 | (lambda (process change) 900 | (let ((websocket (process-get process :websocket))) 901 | (websocket-debug websocket "State change to %s" change) 902 | (when (and 903 | (member (process-status process) '(closed failed exit signal)) 904 | (not (eq 'closed (websocket-ready-state websocket)))) 905 | (websocket-try-callback 'websocket-on-close 'on-close websocket))))))) 906 | 907 | (defun websocket-create-headers (url key protocol extensions custom-headers-alist) 908 | "Create connections headers for the given URL, KEY, PROTOCOL, and EXTENSIONS. 909 | Additionally, the CUSTOM-HEADERS-ALIST is passed from the client. 910 | All these parameters are defined as in `websocket-open'." 911 | (let* ((parsed-url (url-generic-parse-url url)) 912 | (host-port (if (url-port-if-non-default parsed-url) 913 | (format "%s:%s" (url-host parsed-url) (url-port parsed-url)) 914 | (url-host parsed-url))) 915 | (cookie-header (url-cookie-generate-header-lines 916 | host-port (car (url-path-and-query parsed-url)) 917 | (equal (url-type parsed-url) "wss")))) 918 | (concat 919 | (format (concat "Host: %s\r\n" 920 | "Upgrade: websocket\r\n" 921 | "Connection: Upgrade\r\n" 922 | "Sec-WebSocket-Key: %s\r\n" 923 | "Sec-WebSocket-Version: 13\r\n" 924 | (when protocol 925 | (concat 926 | (mapconcat 927 | (lambda (protocol) 928 | (format "Sec-WebSocket-Protocol: %s" protocol)) 929 | protocol "\r\n") 930 | "\r\n")) 931 | (when extensions 932 | (format "Sec-WebSocket-Extensions: %s\r\n" 933 | (mapconcat 934 | (lambda (ext) 935 | (concat 936 | (car ext) 937 | (when (cdr ext) "; ") 938 | (when (cdr ext) 939 | (mapconcat 'identity (cdr ext) "; ")))) 940 | extensions ", ")))) 941 | host-port 942 | key 943 | protocol) 944 | (when cookie-header cookie-header) 945 | (mapconcat (lambda (cons) (format "%s: %s" (car cons) (cdr cons))) 946 | custom-headers-alist "\r\n") 947 | (when custom-headers-alist "\r\n") 948 | "\r\n"))) 949 | 950 | (defun websocket-get-server-response (websocket client-protocols client-extensions) 951 | "Get the websocket response from client WEBSOCKET." 952 | (let ((separator "\r\n")) 953 | (concat "HTTP/1.1 101 Switching Protocols" separator 954 | "Upgrade: websocket" separator 955 | "Connection: Upgrade" separator 956 | "Sec-WebSocket-Accept: " 957 | (websocket-accept-string websocket) separator 958 | (let ((protocols 959 | (websocket-intersect client-protocols 960 | (websocket-protocols websocket)))) 961 | (when protocols 962 | (concat 963 | (mapconcat 964 | (lambda (protocol) (format "Sec-WebSocket-Protocol: %s" 965 | protocol)) protocols separator) 966 | separator))) 967 | (let ((extensions (websocket-intersect 968 | client-extensions 969 | (websocket-extensions websocket)))) 970 | (when extensions 971 | (concat 972 | (mapconcat 973 | (lambda (extension) (format "Sec-Websocket-Extensions: %s" 974 | extension)) extensions separator) 975 | separator))) 976 | separator))) 977 | 978 | (defun websocket-server-filter (process output) 979 | "This acts on all OUTPUT from websocket clients PROCESS." 980 | (let* ((ws (process-get process :websocket)) 981 | (text (concat (websocket-inflight-input ws) output))) 982 | (setf (websocket-inflight-input ws) nil) 983 | (cond ((eq (websocket-ready-state ws) 'connecting) 984 | ;; check for connection string 985 | (let ((end-of-header-pos 986 | (let ((pos (string-match "\r\n\r\n" text))) 987 | (when pos (+ 4 pos))))) 988 | (if end-of-header-pos 989 | (progn 990 | (let ((header-info (websocket-verify-client-headers text))) 991 | (if header-info 992 | (progn (setf (websocket-accept-string ws) 993 | (websocket-calculate-accept 994 | (plist-get header-info :key))) 995 | (process-send-string 996 | process 997 | (websocket-get-server-response 998 | ws (plist-get header-info :protocols) 999 | (plist-get header-info :extensions))) 1000 | (setf (websocket-ready-state ws) 'open) 1001 | (setf (websocket-origin ws) (plist-get header-info :origin)) 1002 | (websocket-try-callback 'websocket-on-open 1003 | 'on-open ws)) 1004 | (message "Invalid client headers found in: %s" output) 1005 | (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n") 1006 | (websocket-close ws))) 1007 | (when (> (length text) (+ 1 end-of-header-pos)) 1008 | (websocket-server-filter process (substring 1009 | text 1010 | end-of-header-pos)))) 1011 | (setf (websocket-inflight-input ws) text)))) 1012 | ((eq (websocket-ready-state ws) 'open) 1013 | (websocket-process-input-on-open-ws ws text)) 1014 | ((eq (websocket-ready-state ws) 'closed) 1015 | (message "WARNING: Should not have received further input on closed websocket"))))) 1016 | 1017 | (defun websocket-verify-client-headers (output) 1018 | "Verify the headers from the WEBSOCKET client connection in OUTPUT. 1019 | Unlike `websocket-verify-headers', this is a quieter routine. We 1020 | don't want to error due to a bad client, so we just print out 1021 | messages and a plist containing `:key', the websocket key, 1022 | `:protocols' and `:extensions'." 1023 | (cl-block nil 1024 | (let ((case-fold-search t) 1025 | (plist)) 1026 | (unless (string-match "HTTP/1.1" output) 1027 | (message "Websocket client connection: HTTP/1.1 not found") 1028 | (cl-return nil)) 1029 | (unless (string-match "^Host: " output) 1030 | (message "Websocket client connection: Host header not found") 1031 | (cl-return nil)) 1032 | (unless (string-match "^Upgrade: websocket\r\n" output) 1033 | (message "Websocket client connection: Upgrade: websocket not found") 1034 | (cl-return nil)) 1035 | (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output) 1036 | (setq plist (plist-put plist :key (match-string 1 output))) 1037 | (message "Websocket client connect: No key sent") 1038 | (cl-return nil)) 1039 | (unless (string-match "^Sec-WebSocket-Version: 13" output) 1040 | (message "Websocket client connect: Websocket version 13 not found") 1041 | (cl-return nil)) 1042 | (when (string-match "^Sec-WebSocket-Protocol:" output) 1043 | (setq plist (plist-put plist :protocols (websocket-parse-repeated-field 1044 | output 1045 | "Sec-Websocket-Protocol")))) 1046 | (when (string-match "^Sec-WebSocket-Extensions:" output) 1047 | (setq plist (plist-put plist :extensions (websocket-parse-repeated-field 1048 | output 1049 | "Sec-Websocket-Extensions")))) 1050 | (when (string-match "^Origin: \\(.+\\)\r\n" output) 1051 | (setq plist (plist-put plist :origin (match-string 1 output)))) 1052 | plist))) 1053 | 1054 | (provide 'websocket) 1055 | 1056 | ;;; websocket.el ends here 1057 | --------------------------------------------------------------------------------