commit c4793b1b11b638e21c2ed67c4bdf851ab6f97519 from: Lukas Henkel date: Sun Aug 31 12:11:29 2025 UTC Add atomic-chome and somehow everything reformatted commit - bba2ab69a95ecb64f74c9401f764f67340655b3f commit + c4793b1b11b638e21c2ed67c4bdf851ab6f97519 blob - /dev/null blob + e576e8d46294d00efd11ba6b795ec33ef0b326eb (mode 644) --- /dev/null +++ elpa/atomic-chrome-2.0.0/atomic-chrome-autoloads.el @@ -0,0 +1,32 @@ +;;; atomic-chrome-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from atomic-chrome.el + +(autoload 'atomic-chrome-start-server "atomic-chrome" "\ +Start websocket server for atomic-chrome." t) +(autoload 'atomic-chrome-stop-server "atomic-chrome" "\ +Stop websocket server for atomic-chrome." t) +(register-definition-prefixes "atomic-chrome" '("atomic-chrome-" "global-atomic-chrome-edit-mode")) + +;;; End of scraped data + +(provide 'atomic-chrome-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; atomic-chrome-autoloads.el ends here blob - /dev/null blob + fb29385788688dc57a74ffe5e33eec1259310149 (mode 644) --- /dev/null +++ elpa/atomic-chrome-2.0.0/atomic-chrome-pkg.el @@ -0,0 +1,12 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "atomic-chrome" "2.0.0" + "Edit Chrome text area with Emacs using Atomic Chrome." + '((emacs "24.3") + (let-alist "1.0.4") + (websocket "1.4")) + :url "https://github.com/alpha22jp/atomic-chrome" + :commit "38ce9127285e1ff45f0f39b9da36a682103bdb96" + :revdesc "38ce9127285e" + :keywords '("chrome" "edit" "textarea") + :authors '(("alpha22jp" . "alpha22jp@gmail.com")) + :maintainers '(("alpha22jp" . "alpha22jp@gmail.com"))) blob - /dev/null blob + 2540e8b7654aadd2099a6f57df4aa3a8b146e31e (mode 644) --- /dev/null +++ elpa/atomic-chrome-2.0.0/atomic-chrome.el @@ -0,0 +1,374 @@ +;;; atomic-chrome.el --- Edit Chrome text area with Emacs using Atomic Chrome + +;; Copyright (C) 2016 alpha22jp + +;; Author: alpha22jp +;; Package-Requires: ((emacs "24.3") (let-alist "1.0.4") (websocket "1.4")) +;; Keywords: chrome edit textarea +;; URL: https://github.com/alpha22jp/atomic-chrome +;; Package-Version: 2.0.0 +;; Package-Revision: 38ce9127285e + +;; This program is free software; you can redistribute it and/or modify it under +;; the terms of the GNU General Public License as published by the Free Software +;; Foundation; either version 2 of the License, or (at your option) any later +;; version. + +;; This program is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;; details. + +;; You should have received a copy of the GNU General Public License along with +;; this program; if not, write to the Free Software Foundation, Inc., 51 +;; Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This is the Emacs version of Atomic Chrome which is an extension for Google +;; Chrome browser that allows you to edit text areas of the browser in Emacs. +;; +;; It's similar to Edit with Emacs, but has some advantages as below with the +;; help of websocket. +;; +;; * Live update +;; The input on Emacs is reflected to the browser instantly and continuously. +;; * Bidirectional communication +;; You can edit both on the browser and Emacs, they are synced to the same. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'json) +(require 'let-alist) +(require 'websocket) + +(defgroup atomic-chrome nil + "Edit Chrome text area with Emacs using Atomic Chrome." + :prefix "atomic-chrome-" + :group 'applications) + +(defcustom atomic-chrome-extension-type-list '(atomic-chrome ghost-text) + "List of chrome extension type available." + :type '(repeat (choice (const :tag "Atomic Chrome" atomic-chrome) + (const :tag "Ghost Text" ghost-text))) + :group 'atomic-chrome) + +(defcustom atomic-chrome-buffer-open-style 'split + "Specify the style to open new buffer for editing." + :type '(choice (const :tag "Open buffer with full window" full) + (const :tag "Open buffer with splitted window" split) + (const :tag "Open buffer with new frame" frame)) + :group 'atomic-chrome) + +(defcustom atomic-chrome-buffer-frame-width 80 + "Width of editing buffer frame." + :type 'integer + :group 'atomic-chrome) + +(defcustom atomic-chrome-buffer-frame-height 25 + "Height of editing buffer frame." + :type 'integer + :group 'atomic-chrome) + +(defcustom atomic-chrome-enable-auto-update t + "If non-nil, edit on Emacs is reflected to Chrome instantly, \ +otherwise you need to type \"C-xC-s\" manually." + :type 'boolean + :group 'atomic-chrome) + +(defcustom atomic-chrome-enable-bidirectional-edit t + "If non-nil, you can edit both on Chrome text area and Emacs, \ +otherwise edit on Chrome is ignored while editing on Emacs." + :type 'boolean + :group 'atomic-chrome) + +(defcustom atomic-chrome-default-major-mode 'text-mode + "Default major mode for editing buffer." + :type 'function + :group 'atomic-chrome) + +(defcustom atomic-chrome-url-major-mode-alist nil + "Association list of URL regexp and corresponding major mode \ +which is used to select major mode for specified website." + :type '(alist :key-type (string :tag "regexp") + :value-type (function :tag "major mode")) + :group 'atomic-chrome) + +(defcustom atomic-chrome-edit-mode-hook nil + "Customizable hook which run when the editing buffer is created." + :type 'hook + :group 'atomic-chrome) + +(defcustom atomic-chrome-edit-done-hook nil + "Customizable hook which run when the editing buffer is closed." + :type 'hook + :group 'atomic-chrome) + +(defvar atomic-chrome-server-atomic-chrome nil + "Websocket server connection handle for Atomic Chrome.") + +(defvar atomic-chrome-server-ghost-text nil + "Websocket server connection handle for Ghost Text.") + +(defvar atomic-chrome-buffer-table (make-hash-table :test 'equal) + "Hash table of editing buffer and its assciated data. +Each element has a list consisting of (websocket, frame).") + +(defun atomic-chrome-get-websocket (buffer) + "Lookup websocket associated with buffer BUFFER \ +from `atomic-chrome-buffer-table'." + (nth 0 (gethash buffer atomic-chrome-buffer-table))) + +(defun atomic-chrome-get-frame (buffer) + "Lookup frame associated with buffer BUFFER \ +from `atomic-chrome-buffer-table'." + (nth 1 (gethash buffer atomic-chrome-buffer-table))) + +(defun atomic-chrome-get-buffer-by-socket (socket) + "Lookup buffer which is associated to the websocket SOCKET \ +from `atomic-chrome-buffer-table'." + (let (buffer) + (cl-loop for key being the hash-keys of atomic-chrome-buffer-table + using (hash-values val) + do (when (equal (nth 0 val) socket) (setq buffer key))) + buffer)) + +(defun atomic-chrome-close-connection () + "Close client connection associated with current buffer." + (let ((socket (atomic-chrome-get-websocket (current-buffer)))) + (when socket + (remhash (current-buffer) atomic-chrome-buffer-table) + (websocket-close socket)))) + +(defun atomic-chrome-send-buffer-text () + "Send request to update text with current buffer content." + (interactive) + (let ((socket (atomic-chrome-get-websocket (current-buffer))) + (text (buffer-substring-no-properties (point-min) (point-max)))) + (when (and socket text) + (websocket-send-text + socket + (json-encode + (if (eq (websocket-server-conn socket) atomic-chrome-server-ghost-text) + (list (cons "text" text)) + (list '("type" . "updateText") + (cons "payload" (list (cons "text" text)))))))))) + +(defun atomic-chrome-set-major-mode (url) + "Set major mode for editing buffer depending on URL. +`atomic-chrome-url-major-mode-alist' can be used to select major mode. +The specified major mode is used if URL matches to one of the alist, +otherwise fallback to `atomic-chrome-default-major-mode'" + (funcall (or (and url (assoc-default url + atomic-chrome-url-major-mode-alist + 'string-match)) + atomic-chrome-default-major-mode))) + +(defun atomic-chrome-show-edit-buffer (buffer title) + "Show editing buffer BUFFER by creating a frame with title TITLE, \ +or raising the selected frame depending on `atomic-chrome-buffer-open-style'." + (let ((edit-frame nil) + (frame-params (list (cons 'name (format "Atomic Chrome: %s" title)) + (cons 'width atomic-chrome-buffer-frame-width) + (cons 'height atomic-chrome-buffer-frame-height)))) + (when (eq atomic-chrome-buffer-open-style 'frame) + (setq edit-frame + (if (memq window-system '(ns mac)) + ;; Avoid using make-frame-on-display for Mac OS. + (make-frame frame-params) + (make-frame-on-display (getenv "DISPLAY") frame-params))) + (select-frame edit-frame)) + (if (eq atomic-chrome-buffer-open-style 'split) + (pop-to-buffer buffer) + (switch-to-buffer buffer)) + (raise-frame edit-frame) + (select-frame-set-input-focus (window-frame (selected-window))) + edit-frame)) + +(defun atomic-chrome-create-buffer (socket url title text) + "Create buffer associated with websocket specified by SOCKET. +URL is used to determine the major mode of the buffer created, +TITLE is used for the buffer name and TEXT is inserted to the buffer." + (let ((buffer (generate-new-buffer title))) + (with-current-buffer buffer + (puthash buffer + (list socket (atomic-chrome-show-edit-buffer buffer title)) + atomic-chrome-buffer-table) + (atomic-chrome-set-major-mode url) + (insert text)))) + +(defun atomic-chrome-close-edit-buffer (buffer) + "Close buffer BUFFER if it's one of Atomic Chrome edit buffers." + (let ((frame (atomic-chrome-get-frame buffer))) + (with-current-buffer buffer + (save-restriction + (run-hooks 'atomic-chrome-edit-done-hook) + (when frame (delete-frame frame)) + (kill-buffer buffer))))) + +(defun atomic-chrome-close-current-buffer () + "Close current buffer and connection from client." + (interactive) + (atomic-chrome-close-edit-buffer (current-buffer))) + +(defun atomic-chrome-update-buffer (socket text) + "Update text on buffer associated with SOCKET to TEXT." + (let ((buffer (atomic-chrome-get-buffer-by-socket socket))) + (when buffer + (with-current-buffer buffer + (erase-buffer) + (insert text))))) + +(defun atomic-chrome-on-message (socket frame) + "Function to handle data received from websocket client specified by SOCKET, \ +where FRAME show raw data received." + (let ((msg (json-read-from-string + (decode-coding-string + (string-make-unibyte (websocket-frame-payload frame)) 'utf-8)))) + (let-alist msg + (if (eq (websocket-server-conn socket) atomic-chrome-server-ghost-text) + (if (atomic-chrome-get-buffer-by-socket socket) + (atomic-chrome-update-buffer socket .text) + (atomic-chrome-create-buffer socket .url .title .text)) + (cond ((string= .type "register") + (atomic-chrome-create-buffer socket .payload.url .payload.title .payload.text)) + ((string= .type "updateText") + (when atomic-chrome-enable-bidirectional-edit + (atomic-chrome-update-buffer socket .payload.text)))))))) + +(defun atomic-chrome-on-close (socket) + "Function to handle request from client to close websocket SOCKET." + (let ((buffer (atomic-chrome-get-buffer-by-socket socket))) + (when buffer (atomic-chrome-close-edit-buffer buffer)))) + +(defvar atomic-chrome-edit-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-x C-s") 'atomic-chrome-send-buffer-text) + (define-key map (kbd "C-c C-c") 'atomic-chrome-close-current-buffer) + map) + "Keymap for minor mode `atomic-chrome-edit-mode'.") + +(define-minor-mode atomic-chrome-edit-mode + "Minor mode enabled on buffers opened by Emacs Chrome server." + :group 'atomic-chrome + :lighter " AtomicChrome" + :init-value nil + :keymap atomic-chrome-edit-mode-map + (when atomic-chrome-edit-mode + (add-hook 'kill-buffer-hook 'atomic-chrome-close-connection nil t) + (when atomic-chrome-enable-auto-update + (add-hook 'post-command-hook 'atomic-chrome-send-buffer-text nil t)))) + +(defun atomic-chrome-turn-on-edit-mode () + "Turn on `atomic-chrome-edit-mode' if the buffer is an editing buffer." + (when (gethash (current-buffer) atomic-chrome-buffer-table) + (atomic-chrome-edit-mode t))) + +(define-global-minor-mode global-atomic-chrome-edit-mode + atomic-chrome-edit-mode atomic-chrome-turn-on-edit-mode) + +(defadvice save-buffers-kill-emacs + (before atomic-chrome-server-stop-before-kill-emacs) + "Call `atomic-chrome-close-server' before closing Emacs to avoid users \ +being prompted to kill the websocket server process." + (atomic-chrome-stop-server)) + +(defun atomic-chrome-start-websocket-server (port) + "Create websocket server on port PORT." + (websocket-server + port + :host 'local + :on-message #'atomic-chrome-on-message + :on-open nil + :on-close #'atomic-chrome-on-close)) + +(defun atomic-chrome-start-httpd () + "Start the HTTP server for Ghost Text query." + (interactive) + (make-network-process + :name "atomic-chrome-httpd" + :family 'ipv4 + :host 'local + :service 4001 + :filter 'atomic-chrome-httpd-process-filter + :filter-multibyte nil + :server t)) + +(defun atomic-chrome-normalize-header (header) + "Destructively capitalize the components of HEADER." + (mapconcat #'capitalize (split-string header "-") "-")) + +(defun atomic-chrome-httpd-parse-string (string) + "Parse client http header STRING into alist." + (let* ((lines (split-string string "[\n\r]+")) + (req (list (split-string (car lines)))) + (post (cadr (split-string string "\r\n\r\n")))) + (dolist (line (butlast (cdr lines))) + (push (list (atomic-chrome-normalize-header (car (split-string line ": "))) + (mapconcat #'identity + (cdr (split-string line ": ")) ": ")) + req)) + (push (list "Content" post) req) + (reverse req))) + +(defun atomic-chrome-httpd-process-filter (proc string) + "Process filter of PROC which run each time client make a request. +STRING is the string process received." + (setf string (concat (process-get proc :previous-string) string)) + (let* ((request (atomic-chrome-httpd-parse-string string)) + (content-length (cadr (assoc "Content-Length" request))) + (uri (cl-cadar request)) + (content (cadr (assoc "Content" request)))) + (if (and content-length + (< (string-bytes content) (string-to-number content-length))) + (process-put proc :previous-string string) + (atomic-chrome-httpd-send-response proc)))) + +(defun atomic-chrome-httpd-send-response (proc) + "Send an HTTP 200 OK response back to process PROC." + (when (processp proc) + (unless atomic-chrome-server-ghost-text + (setq atomic-chrome-server-ghost-text + (atomic-chrome-start-websocket-server 64293))) + (let ((header "HTTP/1.0 200 OK\nContent-Type: application/json\n") + (body (json-encode '(:ProtocolVersion 1 :WebSocketPort 64293)))) + (process-send-string proc (concat header "\n" body)) + (process-send-eof proc)))) + +;;;###autoload +(defun atomic-chrome-start-server () + "Start websocket server for atomic-chrome." + (interactive) + (and (not atomic-chrome-server-atomic-chrome) + (memq 'atomic-chrome atomic-chrome-extension-type-list) + (setq atomic-chrome-server-atomic-chrome + (atomic-chrome-start-websocket-server 64292))) + (and (not (process-status "atomic-chrome-httpd")) + (memq 'ghost-text atomic-chrome-extension-type-list) + (atomic-chrome-start-httpd)) + (global-atomic-chrome-edit-mode 1) + (ad-activate 'save-buffers-kill-emacs)) + +;;;###autoload +(defun atomic-chrome-stop-server nil + "Stop websocket server for atomic-chrome." + (interactive) + (when atomic-chrome-server-atomic-chrome + (websocket-server-close atomic-chrome-server-atomic-chrome) + (setq atomic-chrome-server-atomic-chrome nil)) + (when atomic-chrome-server-ghost-text + (websocket-server-close atomic-chrome-server-ghost-text) + (setq atomic-chrome-server-ghost-text nil)) + (when (process-status "atomic-chrome-httpd") + (delete-process "atomic-chrome-httpd")) + (ad-disable-advice 'save-buffers-kill-emacs + 'before 'atomic-chrome-server-stop-before-kill-emacs) + ;; Disabling advice doesn't take effect until you (re-)activate + ;; all advice for the function. + (ad-activate 'save-buffers-kill-emacs) + (global-atomic-chrome-edit-mode 0)) + +(provide 'atomic-chrome) + +;;; atomic-chrome.el ends here blob - /dev/null blob + ecbc0593737be657aef92e3adcf3bcbd6fdb812e (mode 644) --- /dev/null +++ elpa/websocket-1.15/COPYING @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. \ No newline at end of file blob - /dev/null blob + 465c9ef4b016aef162413dd0314c70ec040f432e (mode 644) --- /dev/null +++ elpa/websocket-1.15/README-elpa @@ -0,0 +1,55 @@ +1 Description +═════════════ + + This is a elisp library for websocket clients to talk to websocket + servers, and for websocket servers to accept connections from + websocket clients. This library is designed to be used by other + library writers, to write apps that use websockets, and is not useful + by itself. + + An example of how to use the library is in the + [websocket-functional-test.el] file. + + This library is compatible with emacs 23 and 24, although only emacs + 24 support secure websockets. + + +[websocket-functional-test.el] + + + +2 Version release checklist +═══════════════════════════ + + Each version that is released should be checked with this checklist: + + • ☐ All ert test passing + • ☐ Functional test passing on emacs 23 and 24 + • ☐ websocket.el byte compiling cleanly. + + +3 Existing clients: +═══════════════════ + + • [Emacs IPython Notebook] + • [Emacs Realtime Markdown Viewer] + • [Kite] + • [Markdown-preview-mode] + • [Org-Roam-UI] + + If you are using this module for your own emacs package, please let me + know by editing this file, adding your project, and sending a pull + request to this repository. + + +[Emacs IPython Notebook] + +[Emacs Realtime Markdown Viewer] + + +[Kite] + +[Markdown-preview-mode] + + +[Org-Roam-UI] blob - /dev/null blob + 83f00cb6bd7cf6b3e44aa55c291c7d0c806e4e1e (mode 644) --- /dev/null +++ elpa/websocket-1.15/README.org @@ -0,0 +1,33 @@ +* Description +This is a elisp library for websocket clients to talk to websocket +servers, and for websocket servers to accept connections from +websocket clients. This library is designed to be used by other +library writers, to write apps that use websockets, and is not useful +by itself. + +An example of how to use the library is in the +[[https://github.com/ahyatt/emacs-websocket/blob/master/websocket-functional-test.el][websocket-functional-test.el]] file. + +This library is compatible with emacs 23 and 24, although only emacs +24 support secure websockets. + +* Version release checklist + +Each version that is released should be checked with this checklist: + +- [ ] All ert test passing +- [ ] Functional test passing on emacs 23 and 24 +- [ ] websocket.el byte compiling cleanly. + +* Existing clients: + +- [[https://github.com/tkf/emacs-ipython-notebook][Emacs IPython Notebook]] +- [[https://github.com/syohex/emacs-realtime-markdown-viewer][Emacs Realtime Markdown Viewer]] +- [[https://github.com/jscheid/kite][Kite]] +- [[https://github.com/ancane/markdown-preview-mode][Markdown-preview-mode]] +- [[https://github.com/org-roam/org-roam-ui][Org-Roam-UI]] + +If you are using this module for your own emacs package, please let me +know by editing this file, adding your project, and sending a pull +request to this repository. + blob - /dev/null blob + 46cf62d94d9bdeb0f78c73d96191d40286ff111e (mode 755) --- /dev/null +++ elpa/websocket-1.15/testserver.py @@ -0,0 +1,35 @@ +#!/usr/bin/env python3 +import logging +import tornado +import tornado.web +from tornado import httpserver +from tornado import ioloop +from tornado import websocket + + +class EchoWebSocket(websocket.WebSocketHandler): + + def open(self): + logging.info("OPEN") + + def on_message(self, message): + logging.info("ON_MESSAGE: {0}".format(message)) + self.write_message(message) + + def on_close(self): + logging.info("ON_CLOSE") + + def allow_draft76(self): + return False + + +if __name__ == "__main__": + import tornado.options + tornado.options.parse_command_line() + application = tornado.web.Application([ + (r"/", EchoWebSocket), + ]) + server = httpserver.HTTPServer(application) + server.listen(9999, "127.0.0.1") + logging.info("STARTED: Server start listening") + ioloop.IOLoop.instance().start() blob - /dev/null blob + f01cdb66191c9a9c2559e899ec5befea286003b7 (mode 644) --- /dev/null +++ elpa/websocket-1.15/websocket-autoloads.el @@ -0,0 +1,38 @@ +;;; websocket-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from websocket.el + +(register-definition-prefixes "websocket" '("websocket-")) + + +;;; Generated autoloads from websocket-functional-test.el + +(register-definition-prefixes "websocket-functional-test" '("websocket-")) + + +;;; Generated autoloads from websocket-test.el + +(register-definition-prefixes "websocket-test" '("websocket-test-")) + +;;; End of scraped data + +(provide 'websocket-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; websocket-autoloads.el ends here blob - /dev/null blob + 8fbcdf3d8bcd238400d1e88a6aced35420be990b (mode 644) --- /dev/null +++ elpa/websocket-1.15/websocket-functional-test.el @@ -0,0 +1,98 @@ +;;; websocket-functional-test.el --- Simple functional testing + +;; Copyright (c) 2013, 2016 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; These are functional tests that may fail for various environmental reasons, +;; such as blocked ports. For example Windows users have to have gnutls DLLs in +;; the Emacs bin directory for this to work. A firewall may also interfere with +;; these tests. +;; +;; These tests are written to test the basic connectivity and message-sending. +;; Corner-cases and error handling is tested in websocket-test.el. + +(require 'tls) ;; tests a particular bug we had on Emacs 23 +(require 'websocket) +(require 'cl) + +;;; Code: + +(defmacro websocket-test-wait-with-timeout (timeout &rest body) + "Run BODY until true or TIMEOUT (in seconds) is reached. + +Will return false if the timeout was reached. This macro is not +written to be used widely." + `(let ((begin (current-time)) + (result nil)) + (while (and (< (- (float-time (time-subtract (current-time) begin))) ,timeout) (not result)) + (setq result ,@body) + (sleep-for 0.5)) + result)) + +(defun websocket-functional-client-test (wstest-server-url) + "Run the main part of an ert test against WSTEST-SERVER-URL." + ;; the server may have an untrusted certificate, for the test to proceed, we + ;; need to disable trust checking. + (let* ((tls-checktrust nil) + (wstest-closed nil) + (wstest-msg) + (wstest-server-proc) + (wstest-ws + (websocket-open + wstest-server-url + :on-message (lambda (_websocket frame) + (setq wstest-msg (websocket-frame-text frame))) + :on-close (lambda (_websocket) (setq wstest-closed t))))) + (should (websocket-test-wait-with-timeout 2 (websocket-openp wstest-ws))) + (should (websocket-test-wait-with-timeout 2 (eq 'open (websocket-ready-state wstest-ws)))) + (should (null wstest-msg)) + (websocket-send-text wstest-ws "Hi!") + (should (websocket-test-wait-with-timeout 5 (equal wstest-msg "Hi!"))) + (websocket-close wstest-ws))) + +(ert-deftest websocket-client-with-local-server () + ;; If testserver.py cannot start, this test will fail. + (let ((proc (start-process + "websocket-testserver" "*websocket-testserver*" + "python3" "testserver.py" "--log_to_stderr" "--logging=debug"))) + (when proc + (sleep-for 1) + (websocket-functional-client-test "ws://127.0.0.1:9999")))) + +(ert-deftest websocket-server () + (let* ((wstest-closed) + (wstest-msg) + (server-conn (websocket-server + 9998 + :host 'local + :on-message (lambda (ws frame) + (websocket-send-text + ws (websocket-frame-text frame))) + :on-close (lambda (_websocket) + (setq wstest-closed t)))) + (wstest-ws (websocket-open + "ws://localhost:9998" + :on-message (lambda (_websocket frame) + (setq wstest-msg (websocket-frame-text frame)))))) + (should (websocket-test-wait-with-timeout 1 (websocket-openp wstest-ws))) + (websocket-send-text wstest-ws "你好") + (should (websocket-test-wait-with-timeout 1 (equal wstest-msg "你好"))) + (websocket-server-close server-conn) + (should (websocket-test-wait-with-timeout 1 wstest-closed)))) + +(provide 'websocket-functional-test) +;;; websocket-functional-test.el ends here blob - /dev/null blob + 1729207ce7471f52033ccfd0dc7d1bd30f9b2547 (mode 644) --- /dev/null +++ elpa/websocket-1.15/websocket-pkg.el @@ -0,0 +1,2 @@ +;; Generated package description from websocket.el -*- no-byte-compile: t -*- +(define-package "websocket" "1.15" "Emacs WebSocket client and server" '((cl-lib "0.5")) :commit "40c208eaab99999d7c1e4bea883648da24c03be3" :authors '(("Andrew Hyatt" . "ahyatt@gmail.com")) :maintainer '("Andrew Hyatt" . "ahyatt@gmail.com") :keywords '("communication" "websocket" "server") :url "https://github.com/ahyatt/emacs-websocket") blob - /dev/null blob + c133272662d6395baad829f0a9bbfa5d4b13dca5 (mode 644) --- /dev/null +++ elpa/websocket-1.15/websocket-test.el @@ -0,0 +1,730 @@ +;;; websocket-test.el --- Unit tests for the websocket layer + +;; Copyright (c) 2013 Free Software Foundation, Inc. +;; +;; Author: Andrew Hyatt +;; Maintainer: Andrew Hyatt +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; This defines and runs ert unit tests. You can download ert from: +;; http://github.com/ohler/ert, it also comes with Emacs 24 and above. + +(require 'ert) +(require 'websocket) +(eval-when-compile (require 'cl)) + +(ert-deftest websocket-genbytes-length () + (loop repeat 100 + do (should (= (string-bytes (websocket-genbytes 16)) 16)))) + +(ert-deftest websocket-calculate-accept () + ;; This example comes straight from RFC 6455 + (should + (equal "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" + (websocket-calculate-accept "dGhlIHNhbXBsZSBub25jZQ==")))) + +(defconst websocket-test-hello "\x81\x05\x48\x65\x6c\x6c\x6f" + "'Hello' string example, taken from the RFC.") + +(defconst websocket-test-masked-hello + "\x81\x85\x37\xfa\x21\x3d\x7f\x9f\x4d\x51\x58" + "'Hello' masked string example, taken from the RFC.") + +(ert-deftest websocket-get-bytes () + (should (equal #x5 (websocket-get-bytes "\x5" 1))) + (should (equal #x101 (websocket-get-bytes "\x1\x1" 2))) + (should (equal #xffffff + (websocket-get-bytes "\x0\x0\x0\x0\x0\xFF\xFF\xFF" 8))) + (should-error (websocket-get-bytes "\x0\x0\x0\x1\x0\x0\x0\x1" 8) + :type 'websocket-unparseable-frame) + (should-error (websocket-get-bytes "\x0\x0\x0" 3)) + (should-error (websocket-get-bytes "\x0" 2) :type 'websocket-unparseable-frame)) + +(ert-deftest websocket-get-opcode () + (should (equal 'text (websocket-get-opcode websocket-test-hello)))) + +(ert-deftest websocket-get-payload-len () + (should (equal '(5 . 1) + (websocket-get-payload-len + (substring websocket-test-hello 1)))) + (should (equal '(200 . 3) + (websocket-get-payload-len + (bindat-pack '((:len u8) (:val u16)) + `((:len . 126) + (:val . 200)))))) + ;; we don't want to hit up any limits even on strange emacs builds, + ;; so this test has a pretty small test value + (should (equal '(70000 . 9) + (websocket-get-payload-len + (bindat-pack '((:len u8) (:val vec 2 u32)) + `((:len . 127) + (:val . [0 70000]))))))) + +(ert-deftest websocket-read-frame () + (should (equal (make-websocket-frame :opcode 'text :payload "Hello" + :length (length websocket-test-hello) + :completep t) + (websocket-read-frame websocket-test-hello))) + (should (equal (make-websocket-frame :opcode 'text :payload "Hello" + :length (length websocket-test-hello) + :completep t) + (websocket-read-frame (concat websocket-test-hello + "should-not-be-read")))) + (should (equal (make-websocket-frame :opcode 'text :payload "Hello" + :length (length websocket-test-masked-hello) + :completep t) + (websocket-read-frame websocket-test-masked-hello))) + (should (equal (make-websocket-frame :opcode 'text :payload "Hello" + :length (length websocket-test-hello) + :completep nil) + (websocket-read-frame + (concat (unibyte-string + (logand (string-to-char + (substring websocket-test-hello 0 1)) + 127)) + (substring websocket-test-hello 1))))) + (dotimes (i (- (length websocket-test-hello) 1)) + (should-not (websocket-read-frame + (substring websocket-test-hello 0 + (- (length websocket-test-hello) (+ i 1)))))) + (dotimes (i (- (length websocket-test-masked-hello) 1)) + (should-not (websocket-read-frame + (substring websocket-test-masked-hello 0 + (- (length websocket-test-masked-hello) (+ i 1))))))) + +(defun websocket-test-header-with-lines (&rest lines) + (mapconcat 'identity (append lines '("\r\n")) "\r\n")) + +(ert-deftest websocket-verify-response-code () + (should (websocket-verify-response-code "HTTP/1.1 101")) + (should + (equal '(400) (cdr (should-error (websocket-verify-response-code "HTTP/1.1 400") + :type 'websocket-received-error-http-response)))) + (should + (equal '(200) (cdr (should-error (websocket-verify-response-code "HTTP/1.1 200"))))) + (should-error (websocket-verify-response-code "HTTP/1.") + :type 'websocket-invalid-header)) + +(ert-deftest websocket-verify-headers () + (let ((accept "Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=") + (accept-alt-case "Sec-Websocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=") + (invalid-accept "Sec-WebSocket-Accept: bad") + (upgrade "Upgrade: websocket") + (upgrade-alt-case "Upgrade: Websocket") + (connection "Connection: upgrade") + (ws (websocket-inner-create + :conn "fake-conn" :url "ws://foo/bar" + :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=")) + (ws-with-protocol + (websocket-inner-create + :conn "fake-conn" :url "ws://foo/bar" + :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" + :protocols '("myprotocol"))) + (ws-with-extensions + (websocket-inner-create + :conn "fake-conn" :url "ws://foo/bar" + :accept-string "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=" + :extensions '("ext1" "ext2")))) + (should (websocket-verify-headers + ws + (websocket-test-header-with-lines accept upgrade connection))) + ;; Force case sensitivity to make sure we aren't too case sensitive. + (let ((case-fold-search nil)) + (should (websocket-verify-headers + ws + (websocket-test-header-with-lines accept-alt-case upgrade-alt-case connection)))) + (should-error + (websocket-verify-headers + ws + (websocket-test-header-with-lines invalid-accept upgrade connection)) + :type 'websocket-invalid-header) + (should-error (websocket-verify-headers + ws + (websocket-test-header-with-lines upgrade connection)) + :type 'websocket-invalid-header) + (should-error (websocket-verify-headers + ws + (websocket-test-header-with-lines accept connection)) + :type 'websocket-invalid-header) + (should-error (websocket-verify-headers + ws + (websocket-test-header-with-lines accept upgrade)) + :type 'websocket-invalid-header) + (should-error (websocket-verify-headers + ws-with-protocol + (websocket-test-header-with-lines accept upgrade connection)) + :type 'websocket-invalid-header) + (should-error + (websocket-verify-headers + ws-with-protocol + (websocket-test-header-with-lines accept upgrade connection + "Sec-Websocket-Protocol: foo")) + :type 'websocket-invalid-header) + (should + (websocket-verify-headers + ws-with-protocol + (websocket-test-header-with-lines accept upgrade connection + "Sec-Websocket-Protocol: myprotocol"))) + (should (equal '("myprotocol") + (websocket-negotiated-protocols ws-with-protocol))) + (should-error + (websocket-verify-headers + ws-with-extensions + (websocket-test-header-with-lines accept upgrade connection + "Sec-Websocket-Extensions: foo"))) + (should + (websocket-verify-headers + ws-with-extensions + (websocket-test-header-with-lines + accept upgrade connection "Sec-Websocket-Extensions: ext1, ext2; a=1"))) + (should (equal '("ext1" "ext2; a=1") + (websocket-negotiated-extensions ws-with-extensions))) + (should + (websocket-verify-headers + ws-with-extensions + (websocket-test-header-with-lines accept upgrade connection + "Sec-Websocket-Extensions: ext1" + "Sec-Websocket-Extensions: ext2; a=1"))) + (should (equal '("ext1" "ext2; a=1") + (websocket-negotiated-extensions ws-with-extensions))))) + +(ert-deftest websocket-mask-is-unibyte () + (should-not (multibyte-string-p (websocket-mask "\344\275\240\345\245\275" "abcdef")))) + +(ert-deftest websocket-frame-correctly-encoded () + ;; This example comes from https://github.com/ahyatt/emacs-websocket/issues/58. + (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\"}") + ((symbol-function #'websocket-genbytes) + (lambda (&rest _) "\10\206\356\224"))) + (let ((frame (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode 'text + :payload (encode-coding-string text 'raw-text) + :completep t) + t)))) + (should frame) + (should (equal (websocket-frame-payload frame) text))))) + +(ert-deftest websocket-create-headers () + (let ((base-headers (concat "Host: www.example.com\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: key\r\n" + "Sec-WebSocket-Version: 13\r\n"))) + (cl-letf (((symbol-function 'url-cookie-generate-header-lines) + (lambda (host localpart secure) ""))) + (should (equal (concat base-headers "\r\n") + (websocket-create-headers "ws://www.example.com/path" + "key" nil nil nil))) + (should (equal (concat base-headers + "Sec-WebSocket-Protocol: protocol\r\n\r\n") + (websocket-create-headers "ws://www.example.com/path" + "key" '("protocol") nil nil))) + (should (equal + (concat base-headers + "Sec-WebSocket-Extensions: ext1; a; b=2, ext2\r\n\r\n") + (websocket-create-headers "ws://www.example.com/path" + "key" nil + '(("ext1" . ("a" "b=2")) + ("ext2")) nil))) + (should (equal + (concat base-headers "Foo: bar\r\nBaz: boo\r\n\r\n") + (websocket-create-headers "ws://www.example.com/path" + "key" nil nil '(("Foo" . "bar") ("Baz" . "boo")))))) + (cl-letf (((symbol-function 'url-cookie-generate-header-lines) + (lambda (host localpart secure) + (should (equal host "www.example.com:123")) + (should (equal localpart "/path")) + (should secure) + "Cookie: foo=bar\r\n"))) + (should (equal (websocket-create-headers "wss://www.example.com:123/path" + "key" nil nil nil) + (concat + "Host: www.example.com:123\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: key\r\n" + "Sec-WebSocket-Version: 13\r\n" + "Cookie: foo=bar\r\n\r\n")))) + (should + (string-match + "Host: www.example.com:123\r\n" + (websocket-create-headers "ws://www.example.com:123/path" "key" nil nil nil))))) + +(ert-deftest websocket-process-headers () + (cl-flet ((url-cookie-handle-set-cookie + (text) + (should (equal text "foo=bar;")) + ;; test that we have set the implicit buffer variable needed + ;; by url-cookie-handle-set-cookie + (should (equal url-current-object + (url-generic-parse-url "ws://example.com/path"))))) + (websocket-process-headers "ws://example.com/path" + (concat + "HTTP/1.1 101 Switching Protocols\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Set-Cookie: foo=bar;\r\n\r\n"))) + (cl-flet ((url-cookie-handle-set-cookie (text) (should nil))) + (websocket-process-headers "ws://example.com/path" + "HTTP/1.1 101 Switching Protocols\r\n"))) + +(ert-deftest websocket-process-frame () + (let* ((sent) + (processed) + (deleted) + (websocket (websocket-inner-create + :conn t :url t + :on-message (lambda (websocket frame) + (setq + processed + (websocket-frame-payload frame))) + :accept-string t))) + (dolist (opcode '(text binary continuation)) + (setq processed nil) + (should (equal + "hello" + (progn + (funcall (websocket-process-frame + websocket + (make-websocket-frame :opcode opcode :payload "hello"))) + processed)))) + (setq sent nil) + (cl-letf (((symbol-function 'websocket-send) + (lambda (websocket content) (setq sent content)))) + (should (equal + (make-websocket-frame :opcode 'pong :payload "data" :completep t) + (progn + (funcall (websocket-process-frame websocket + (make-websocket-frame :opcode 'ping + :payload "data"))) + sent)))) + (cl-letf (((symbol-function 'delete-process) + (lambda (conn) (setq deleted t)))) + (should (progn + (funcall + (websocket-process-frame websocket + (make-websocket-frame :opcode 'close))) + deleted))))) + +(ert-deftest websocket-process-frame-error-handling () + (let* ((error-called) + (websocket (websocket-inner-create + :conn t :url t :accept-string t + :on-message (lambda (websocket frame) + (message "In on-message") + (error "err")) + :on-error (lambda (ws type err) + (should (eq 'on-message type)) + (setq error-called t))))) + (funcall (websocket-process-frame websocket + (make-websocket-frame :opcode 'text + :payload "hello"))) + (should error-called))) + +(ert-deftest websocket-to-bytes () + ;; We've tested websocket-get-bytes by itself, now we can use it to + ;; help test websocket-to-bytes. + (should (equal 30 (websocket-get-bytes (websocket-to-bytes 30 1) 1))) + (should (equal 300 (websocket-get-bytes (websocket-to-bytes 300 2) 2))) + (should (equal 70000 (websocket-get-bytes (websocket-to-bytes 70000 8) 8))) + ;; Only run if the number we're testing with is not more than the system can + ;; handle. + (if (equal "1" (calc-eval (format "536870912 < %d" most-positive-fixnum))) + (should-error (websocket-to-bytes 536870912 8) + :type 'websocket-frame-too-large)) + (should-error (websocket-to-bytes 30 3)) + (should-error (websocket-to-bytes 300 1)) + ;; I'd like to test the error for 32-byte systems on 8-byte lengths, + ;; but elisp does not allow us to temporarily set constants such as + ;; most-positive-fixnum. + ) + +(ert-deftest websocket-encode-frame () + ;; We've tested websocket-read-frame, now we can use that to help + ;; test websocket-encode-frame. + (should (equal + websocket-test-hello + (websocket-encode-frame + (make-websocket-frame :opcode 'text :payload "Hello" :completep t) nil))) + (dolist (len '(200 70000)) + (let ((long-string (make-string len ?x))) + (should (equal long-string + (websocket-frame-payload + (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode 'text + :payload long-string) t))))))) + (cl-letf (((symbol-function 'websocket-genbytes) + (lambda (n) (substring websocket-test-masked-hello 2 6)))) + (should (equal websocket-test-masked-hello + (websocket-encode-frame + (make-websocket-frame :opcode 'text :payload "Hello" + :completep t) t)))) + (should-not + (websocket-frame-completep + (websocket-read-frame + (websocket-encode-frame (make-websocket-frame :opcode 'text + :payload "Hello" + :completep nil) t)))) + (should (equal 'close (websocket-frame-opcode + (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode 'close :completep t) t))))) + (dolist (opcode '(ping pong)) + (let ((read-frame (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode opcode + :payload "data" + :completep t) t)))) + (should read-frame) + (should (equal + opcode + (websocket-frame-opcode read-frame))) + (should (equal + "data" (websocket-frame-payload read-frame))))) + ;; A frame should be four bytes, even for no-data pings. + (should (equal 2 (websocket-frame-length + (websocket-read-frame + (websocket-encode-frame + (make-websocket-frame :opcode 'ping :completep t) t)))))) + +(ert-deftest websocket-check () + (should (websocket-check (make-websocket-frame :opcode 'close :completep t))) + (should-not + (websocket-check (make-websocket-frame :opcode 'close :completep nil))) + (should-not + (websocket-check (make-websocket-frame :opcode 'close :completep t :payload ""))) + (should (websocket-check (make-websocket-frame :opcode 'text :completep nil + :payload "incompl"))) + (should (websocket-check (make-websocket-frame :opcode 'ping :completep t))) + (should (websocket-check (make-websocket-frame :opcode 'ping :completep t + :payload ""))) + (should (websocket-check (make-websocket-frame :opcode 'pong :completep t + :payload ""))) + (should-not (websocket-check (make-websocket-frame :opcode 'text)))) + +(ert-deftest websocket-close () + (let ((sent-frames) + (processes-deleted)) + (cl-letf (((symbol-function 'websocket-send) + (lambda (websocket frame) (push frame sent-frames))) + ((symbol-function 'websocket-openp) + (lambda (websocket) t)) + ((symbol-function 'kill-buffer) (lambda (buffer) t)) + ((symbol-function 'delete-process) + (lambda (proc) (add-to-list 'processes-deleted proc)))) + (websocket-close (websocket-inner-create + :conn "fake-conn" + :url t + :accept-string t + :on-close 'identity)) + (should (equal sent-frames (list + (make-websocket-frame :opcode 'close + :completep t)))) + (should (equal processes-deleted '("fake-conn")))))) + +(ert-deftest websocket-outer-filter () + (let* ((fake-ws (websocket-inner-create + :conn t :url t :accept-string t + :on-open (lambda (websocket) + (should (eq (websocket-ready-state websocket) + 'open)) + (setq open-callback-called t) + (error "Ignore me!")) + :on-error (lambda (ws type err)))) + (processed-frames) + (frame1 (make-websocket-frame :opcode 'text :payload "foo" :completep t + :length 9)) + (frame2 (make-websocket-frame :opcode 'text :payload "bar" :completep t + :length 9)) + (open-callback-called) + (websocket-frames + (concat + (websocket-encode-frame frame1 t) + (websocket-encode-frame frame2 t)))) + (cl-letf (((symbol-function 'websocket-process-frame) + (lambda (websocket frame) + (lexical-let ((frame frame)) + (lambda () (push frame processed-frames))))) + ((symbol-function 'websocket-verify-headers) + (lambda (websocket output) t)) + ((symbol-function 'websocket-close) (lambda (websocket) t))) + (websocket-outer-filter fake-ws "HTTP/1.1 101 Switching Protocols\r\n") + (websocket-outer-filter fake-ws "Sec-") + (should (eq (websocket-ready-state fake-ws) 'connecting)) + (should-not open-callback-called) + (websocket-outer-filter fake-ws "WebSocket-Accept: acceptstring") + (should-not open-callback-called) + (websocket-outer-filter fake-ws (concat + "\r\n\r\n" + (substring websocket-frames 0 2))) + (should open-callback-called) + (websocket-outer-filter fake-ws (substring websocket-frames 2)) + (should (equal (list frame2 frame1) processed-frames)) + (should-not (websocket-inflight-input fake-ws))) + (cl-letf (((symbol-function 'websocket-close) (lambda (websocket) t))) + (let ((on-error-called)) + (setf (websocket-ready-state fake-ws) 'connecting) + (setf (websocket-on-open fake-ws) (lambda (ws &rest _) t)) + (setf (websocket-on-error fake-ws) + (lambda (_ type err) + (should (eq type 'on-open)) + (should (equal '(websocket-received-error-http-response 500) err)) + (setq on-error-called t))) + (websocket-outer-filter fake-ws "HTTP/1.1 500\r\n\r\n") + (should on-error-called))))) + +(ert-deftest websocket-outer-filter-bad-connection () + (let* ((on-open-calledp) + (websocket-closed-calledp) + (fake-ws (websocket-inner-create + :conn t :url t :accept-string t + :on-open (lambda (websocket) + (setq on-open-calledp t))))) + (cl-letf (((symbol-function 'websocket-verify-response-code) + (lambda (output) t)) + ((symbol-function 'websocket-verify-headers) + (lambda (websocket output) (error "Bad headers!"))) + ((symbol-function 'websocket-close) + (lambda (websocket) (setq websocket-closed-calledp t)))) + (condition-case err + (progn (websocket-outer-filter fake-ws "HTTP/1.1 101\r\n\r\n") + (error "Should have thrown an error!")) + (error + (should-not on-open-calledp) + (should websocket-closed-calledp)))))) + +(ert-deftest websocket-outer-filter-fragmented-header () + (let* ((on-open-calledp) + (websocket-closed-calledp) + (fake-ws (websocket-inner-create + :protocols '("websocket") + :conn t :url t :accept-string "17hG/VoPPd14L9xPSI7LtEr7PQc=" + :on-open (lambda (websocket) + (setq on-open-calledp t))))) + (cl-letf (((symbol-function 'websocket-close) (lambda (websocket) t))) + (websocket-outer-filter fake-ws "HTTP/1.1 101 Web Socket Protocol Handsh") + (websocket-outer-filter fake-ws "ake\r\nConnection: Upgrade\r\n") + (websocket-outer-filter fake-ws "Upgrade: websocket\r\n") + (websocket-outer-filter fake-ws "Sec-websocket-Protocol: websocket\r\n") + (websocket-outer-filter fake-ws "Sec-WebSocket-Accept: 17hG/VoPPd14L9xPSI7LtEr7PQc=\r\n\r\n")))) + +(ert-deftest websocket-send-text () + (cl-letf (((symbol-function 'websocket-send) + (lambda (ws frame) + (should (equal + (websocket-frame-payload frame) + "\344\275\240\345\245\275"))))) + (websocket-send-text nil "你好"))) + +(ert-deftest websocket-send () + (let ((ws (websocket-inner-create :conn t :url t :accept-string t))) + (cl-letf (((symbol-function 'websocket-ensure-connected) (lambda (websocket) t)) + ((symbol-function 'websocket-openp) (lambda (websocket) t)) + ((symbol-function 'process-send-string) (lambda (conn string) t))) + ;; Just make sure there is no error. + (websocket-send ws (make-websocket-frame :opcode 'ping + :completep t))) + (should-error (websocket-send ws + (make-websocket-frame :opcode 'text))) + (should-error (websocket-send ws + (make-websocket-frame :opcode 'close + :payload "bye!" + :completep t)) + :type 'websocket-illegal-frame) + (should-error (websocket-send ws + (make-websocket-frame :opcode :close)) + :type 'websocket-illegal-frame))) + +(ert-deftest websocket-verify-client-headers () + (let* ((http "HTTP/1.1") + (host "Host: authority") + (upgrade "Upgrade: websocket") + (key (format "Sec-Websocket-Key: %s" "key")) + (version "Sec-Websocket-Version: 13") + (protocol "Sec-Websocket-Protocol: protocol") + (extensions1 "Sec-Websocket-Extensions: foo") + (extensions2 "Sec-Websocket-Extensions: bar; baz=2") + (all-required-headers (list host upgrade key version))) + ;; Test that all these headers are necessary + (should (equal + '(:key "key" :protocols ("protocol") :extensions ("foo" "bar; baz=2")) + (websocket-verify-client-headers + (mapconcat 'identity (append (list http "" protocol extensions1 extensions2) + all-required-headers) "\r\n")))) + (should (websocket-verify-client-headers + (mapconcat 'identity + (mapcar 'upcase + (append (list http "" protocol extensions1 extensions2) + all-required-headers)) "\r\n"))) + (dolist (header all-required-headers) + (should-not (websocket-verify-client-headers + (mapconcat 'identity (append (list http "") + (remove header all-required-headers)) + "\r\n")))) + (should-not (websocket-verify-client-headers + (mapconcat 'identity (append (list "HTTP/1.0" "") all-required-headers) + "\r\n"))))) + +(ert-deftest websocket-intersect () + (should (equal '(2) (websocket-intersect '(1 2) '(2 3)))) + (should (equal nil (websocket-intersect '(1 2) '(3 4)))) + (should (equal '(1 2) (websocket-intersect '(1 2) '(1 2))))) + +(ert-deftest websocket-get-server-response () + (let ((ws (websocket-inner-create :conn t :url t :accept-string "key" + :protocols '("spa" "spb") + :extensions '("sea" "seb")))) + (should (equal (concat + "HTTP/1.1 101 Switching Protocols\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Accept: key\r\n\r\n") + (websocket-get-server-response ws nil nil))) + (should (string-match "Sec-Websocket-Protocol: spb\r\n" + (websocket-get-server-response ws '("spb" "spc") nil))) + (should-not (string-match "Sec-Websocket-Protocol:" + (websocket-get-server-response ws '("spc") nil))) + (let ((output (websocket-get-server-response ws '("spa" "spb") nil))) + (should (string-match "Sec-Websocket-Protocol: spa\r\n" output)) + (should (string-match "Sec-Websocket-Protocol: spb\r\n" output))) + (should (string-match "Sec-Websocket-Extensions: sea" + (websocket-get-server-response ws nil '("sea" "sec")))) + (should-not (string-match "Sec-Websocket-Extensions:" + (websocket-get-server-response ws nil '("sec")))) + (let ((output (websocket-get-server-response ws nil '("sea" "seb")))) + (should (string-match "Sec-Websocket-Extensions: sea\r\n" output)) + (should (string-match "Sec-Websocket-Extensions: seb\r\n" output))))) + +(ert-deftest websocket-server-filter () + (let ((on-open-called) + (ws (websocket-inner-create :conn t :url t :accept-string "key" + :on-open (lambda (ws) (setq on-open-called t)))) + (closed) + (response) + (processed)) + (cl-letf (((symbol-function 'process-send-string) (lambda (p text) (setq response text))) + ((symbol-function 'websocket-close) (lambda (ws) (setq closed t))) + ((symbol-function 'process-get) (lambda (process sym) ws))) + ;; Bad request, in two parts + (cl-letf (((symbol-function 'websocket-verify-client-headers) + (lambda (text) nil))) + (websocket-server-filter nil "HTTP/1.0 GET /foo \r\n") + (should-not closed) + (websocket-server-filter nil "\r\n") + (should (equal response "HTTP/1.1 400 Bad Request\r\n\r\n")) + (should-not (websocket-inflight-input ws))) + ;; Good request, followed by packet + (setq closed nil + response nil) + (setf (websocket-inflight-input ws) nil) + (cl-letf (((symbol-function 'websocket-verify-client-headers) + (lambda (text) t)) + ((symbol-function 'websocket-get-server-response) + (lambda (ws protocols extensions) + "response")) + ((symbol-function 'websocket-process-input-on-open-ws) + (lambda (ws text) + (setq processed t) + (should + (equal text websocket-test-hello))))) + (websocket-server-filter nil + (concat "\r\n\r\n" websocket-test-hello)) + (should (equal (websocket-ready-state ws) 'open)) + (should-not closed) + (should (equal response "response")) + (should processed))))) + +(ert-deftest websocket-complete-server-response-test () + ;; Example taken from RFC + (should (equal + (concat "HTTP/1.1 101 Switching Protocols\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=\r\n" + "Sec-WebSocket-Protocol: chat\r\n\r\n" + ) + (let ((header-info + (websocket-verify-client-headers + (concat "GET /chat HTTP/1.1\r\n" + "Host: server.example.com\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n" + "Sec-WebSocket-Protocol: chat, superchat\r\n" + "Sec-WebSocket-Version: 13\r\n")))) + (should header-info) + (let ((ws (websocket-inner-create + :conn t :url t + :accept-string (websocket-calculate-accept + (plist-get header-info :key)) + :protocols '("chat")))) + (websocket-get-server-response + ws + (plist-get header-info :protocols) + (plist-get header-info :extension))))))) + +(ert-deftest websocket-server-close () + (let ((websocket-server-websockets + (list (websocket-inner-create :conn 'conn-a :url t :accept-string t + :server-conn 'a + :ready-state 'open) + (websocket-inner-create :conn 'conn-b :url t :accept-string t + :server-conn 'b + :ready-state 'open) + (websocket-inner-create :conn 'conn-c :url t :accept-string t + :server-conn 'b + :ready-state 'closed))) + (deleted-processes) + (closed-websockets)) + (cl-letf (((symbol-function 'delete-process) + (lambda (conn) (add-to-list 'deleted-processes conn))) + ((symbol-function 'websocket-close) + (lambda (ws) + ;; we always remove on closing in the + ;; actual code. + (setq websocket-server-websockets + (remove ws websocket-server-websockets)) + (should-not (eq (websocket-ready-state ws) 'closed)) + (add-to-list 'closed-websockets ws)))) + (websocket-server-close 'b)) + (should (equal deleted-processes '(b))) + (should (eq 1 (length closed-websockets))) + (should (eq 'conn-b (websocket-conn (car closed-websockets)))) + (should (eq 1 (length websocket-server-websockets))) + (should (eq 'conn-a (websocket-conn (car websocket-server-websockets)))))) + +(ert-deftest websocket-default-error-handler () + (cl-letf (((symbol-function 'try-error) + (lambda (callback-type err expected-message) + (cl-flet ((display-warning + (type message &optional level buffer-name) + (should (eq type 'websocket)) + (should (eq level :error)) + (should (string= message expected-message)))) + (websocket-default-error-handler nil + callback-type + err))))) + (try-error + 'on-message + '(end-of-buffer) + "in callback `on-message': End of buffer") + + (try-error + 'on-close + '(wrong-number-of-arguments 1 2) + "in callback `on-close': Wrong number of arguments: 1, 2"))) blob - /dev/null blob + a5c0591d4f16d23bb15788cfa65fd02e652d9831 (mode 644) --- /dev/null +++ elpa/websocket-1.15/websocket.el @@ -0,0 +1,1056 @@ +;;; websocket.el --- Emacs WebSocket client and server -*- lexical-binding:t -*- + +;; Copyright (c) 2013, 2016-2023 Free Software Foundation, Inc. + +;; Author: Andrew Hyatt +;; Homepage: https://github.com/ahyatt/emacs-websocket +;; Keywords: Communication, Websocket, Server +;; Version: 1.15 +;; Package-Requires: ((cl-lib "0.5")) +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; This implements RFC 6455, which can be found at +;; http://tools.ietf.org/html/rfc6455. +;; +;; This library contains code to connect Emacs as a client to a +;; websocket server, and for Emacs to act as a server for websocket +;; connections. +;; +;; Websockets clients are created by calling `websocket-open', which +;; returns a `websocket' struct. Users of this library use the +;; websocket struct, and can call methods `websocket-send-text', which +;; sends text over the websocket, or `websocket-send', which sends a +;; `websocket-frame' struct, enabling finer control of what is sent. +;; A callback is passed to `websocket-open' that will retrieve +;; websocket frames called from the websocket. Websockets are +;; eventually closed with `websocket-close'. +;; +;; Server functionality is similar. A server is started with +;; `websocket-server' called with a port and the callbacks to use, +;; which returns a process. The process can later be closed with +;; `websocket-server-close'. A `websocket' struct is also created +;; for every connection, and is exposed through the callbacks. + +(require 'bindat) +(require 'url-parse) +(require 'url-cookie) +(require 'seq) +(eval-when-compile (require 'cl-lib)) + +;;; Code: + +(cl-defstruct (websocket + (:constructor nil) + (:constructor websocket-inner-create)) + "A websocket structure. +This follows the W3C Websocket API, except translated to elisp +idioms. The API is implemented in both the websocket struct and +additional methods. Due to how defstruct slots are accessed, all +API methods are prefixed with \"websocket-\" and take a websocket +as an argument, so the distrinction between the struct API and +the additional helper APIs are not visible to the caller. + +A websocket struct is created with `websocket-open'. + +`ready-state' contains one of `connecting', `open', or +`closed', depending on the state of the websocket. + +The W3C API \"bufferedAmount\" call is not currently implemented, +since there is no elisp API to get the buffered amount from the +subprocess. There may, in fact, be output data buffered, +however, when the `on-message' or `on-close' callbacks are +called. + +`on-open', `on-message', `on-close', and `on-error' are described +in `websocket-open'. + +The `negotiated-extensions' slot lists the extensions accepted by +both the client and server, and `negotiated-protocols' does the +same for the protocols." + ;; API + (ready-state 'connecting) + client-data + on-open + on-message + on-close + on-error + negotiated-protocols + negotiated-extensions + (server-p nil :read-only t) + + ;; Other data - clients should not have to access this. + (url (cl-assert nil) :read-only t) + (protocols nil :read-only t) + (extensions nil :read-only t) + (conn (cl-assert nil) :read-only t) + ;; Only populated for servers, this is the server connection. + server-conn + origin + accept-string + (inflight-input nil)) + +(defvar websocket-version "1.12" + "Version numbers of this version of websocket.el.") + +(defvar websocket-debug nil + "Set to true to output debugging info to a per-websocket buffer. +The buffer is ` *websocket URL debug*' where URL is the +URL of the connection.") + +(defconst websocket-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" + "The websocket GUID as defined in RFC 6455. +Do not change unless the RFC changes.") + +(defvar websocket-callback-debug-on-error nil + "If true, when an error happens in a client callback, invoke the debugger. +Having this on can cause issues with missing frames if the debugger is +exited by quitting instead of continuing, so it's best to have this set +to nil unless it is especially needed.") + +(defmacro websocket-document-function (function docstring) + "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc." + (declare (indent defun) + (doc-string 2)) + `(put ',function 'function-documentation ,docstring)) + +(websocket-document-function websocket-on-open + "Accessor for websocket on-open callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(websocket-document-function websocket-on-message + "Accessor for websocket on-message callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(websocket-document-function websocket-on-close + "Accessor for websocket on-close callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(websocket-document-function websocket-on-error + "Accessor for websocket on-error callback. +See `websocket-open' for details. + +\(fn WEBSOCKET)") + +(defun websocket-genbytes (nbytes) + "Generate NBYTES random bytes." + (let ((s (make-string nbytes ?\s))) + (dotimes (i nbytes) + (aset s i (random 256))) + s)) + +(defun websocket-try-callback (websocket-callback callback-type websocket + &rest rest) + "Invoke function WEBSOCKET-CALLBACK with WEBSOCKET and REST args. +If an error happens, it is handled according to +`websocket-callback-debug-on-error'." + ;; This looks like it should be able to done more efficiently, but + ;; I'm not sure that's the case. We can't do it as a macro, since + ;; we want it to change whenever websocket-callback-debug-on-error + ;; changes. + (let ((args rest) + (debug-on-error websocket-callback-debug-on-error)) + (push websocket args) + (if websocket-callback-debug-on-error + (condition-case err + (apply (funcall websocket-callback websocket) args) + ((debug error) (funcall (websocket-on-error websocket) + websocket callback-type err))) + (condition-case err + (apply (funcall websocket-callback websocket) args) + (error (funcall (websocket-on-error websocket) websocket + callback-type err)))))) + +(defun websocket-genkey () + "Generate a key suitable for the websocket handshake." + (base64-encode-string (websocket-genbytes 16))) + +(defun websocket-calculate-accept (key) + "Calculate the expect value of the accept header. +This is based on the KEY from the Sec-WebSocket-Key header." + (base64-encode-string + (sha1 (concat key websocket-guid) nil nil t))) + +(defun websocket-get-bytes (s n) + "From string S, retrieve the value of N bytes. +Return the value as an unsigned integer. The value N must be a +power of 2, up to 8. + +We support getting frames up to 536870911 bytes (2^29 - 1), +approximately 537M long." + (if (= n 8) + (let* ((32-bit-parts + (bindat-get-field (bindat-unpack '((:val vec 2 u32)) s) :val)) + (cval + (logior (ash (aref 32-bit-parts 0) 32) (aref 32-bit-parts 1)))) + (if (and (= (aref 32-bit-parts 0) 0) + (= (ash (aref 32-bit-parts 1) -29) 0)) + cval + (signal 'websocket-unparseable-frame + (list "Frame value found too large to parse!")))) + ;; n is not 8 + (bindat-get-field + (condition-case _ + (bindat-unpack + `((:val + ,(cond ((= n 1) 'u8) + ((= n 2) 'u16) + ((= n 4) 'u32) + ;; This is an error with the library, + ;; not a user-facing, meaningful error. + (t (error + "websocket-get-bytes: Unknown N: %S" n))))) + s) + (args-out-of-range (signal 'websocket-unparseable-frame + (list (format "Frame unexpectedly short: %s" s))))) + :val))) + +(defun websocket-to-bytes (val nbytes) + "Encode the integer VAL in NBYTES of data. +NBYTES much be a power of 2, up to 8. + +This supports encoding values up to 536870911 bytes (2^29 - 1), +approximately 537M long." + (when (and (< nbytes 8) + (> val (expt 2 (* 8 nbytes)))) + ;; not a user-facing error, this must be caused from an error in + ;; this library + (error "websocket-to-bytes: Value %d could not be expressed in %d bytes" + val nbytes)) + (if (= nbytes 8) + (progn + (let* ((hi-32bits (ash val -32)) + ;; This is just VAL on systems that don't have >= 32 bits. + (low-32bits (- val (ash hi-32bits 32)))) + (when (or (> hi-32bits 0) (> (ash low-32bits -29) 0)) + (signal 'websocket-frame-too-large (list val))) + (bindat-pack `((:val vec 2 u32)) + `((:val . [,hi-32bits ,low-32bits]))))) + (bindat-pack + `((:val ,(cond ((= nbytes 1) 'u8) + ((= nbytes 2) 'u16) + ((= nbytes 4) 'u32) + ;; Library error, not system error + (t (error "websocket-to-bytes: Unknown NBYTES: %S" nbytes))))) + `((:val . ,val))))) + +(defun websocket-get-opcode (s) + "Retrieve the opcode from first byte of string S." + (websocket-ensure-length s 1) + (let ((opcode (logand #xf (aref s 0)))) + (cond ((= opcode 0) 'continuation) + ((= opcode 1) 'text) + ((= opcode 2) 'binary) + ((= opcode 8) 'close) + ((= opcode 9) 'ping) + ((= opcode 10) 'pong)))) + +(defun websocket-get-payload-len (s) + "Parse out the payload length from the string S. +We start at position 0, and return a cons of the payload length and how +many bytes were consumed from the string." + (websocket-ensure-length s 1) + (let* ((initial-val (logand 127 (aref s 0)))) + (cond ((= initial-val 127) + (websocket-ensure-length s 9) + (cons (websocket-get-bytes (substring s 1) 8) 9)) + ((= initial-val 126) + (websocket-ensure-length s 3) + (cons (websocket-get-bytes (substring s 1) 2) 3)) + (t (cons initial-val 1))))) + +(cl-defstruct websocket-frame opcode payload length completep) + +(defun websocket-frame-text (frame) + "Given FRAME, return the payload as a utf-8 encoded string." + (cl-assert (websocket-frame-p frame)) + (decode-coding-string (websocket-frame-payload frame) 'utf-8)) + +(defun websocket-mask (key data) + "Using string KEY, mask string DATA according to the RFC. +This is used to both mask and unmask data." + ;; Returning the string as unibyte is important here. Because we set the + ;; string byte by byte, this results in a unibyte string. + (cl-loop + with result = (make-string (length data) ?x) + for i from 0 below (length data) + do (setf (seq-elt result i) (logxor (aref key (mod i 4)) (seq-elt data i))) + finally return result)) + +(defun websocket-ensure-length (s n) + "Ensure the string S has at most N bytes. +Otherwise we throw the error `websocket-incomplete-frame'." + (when (< (length s) n) + (throw 'websocket-incomplete-frame nil))) + +(defun websocket-encode-frame (frame should-mask) + "Encode the FRAME struct to the binary representation. +We mask the frame or not, depending on SHOULD-MASK." + (let* ((opcode (websocket-frame-opcode frame)) + (payload (websocket-frame-payload frame)) + (fin (websocket-frame-completep frame)) + (payloadp (and payload + (memq opcode '(continuation ping pong text binary)))) + (mask-key (when should-mask (websocket-genbytes 4)))) + (apply #'unibyte-string + (let ((val (append (list + (logior (pcase opcode + (`continuation 0) + (`text 1) + (`binary 2) + (`close 8) + (`ping 9) + (`pong 10)) + (if fin 128 0))) + (when payloadp + (list + (logior + (if should-mask 128 0) + (cond ((< (length payload) 126) (length payload)) + ((< (length payload) 65536) 126) + (t 127))))) + (when (and payloadp (>= (length payload) 126)) + (append (websocket-to-bytes + (length payload) + (cond ((< (length payload) 126) 1) + ((< (length payload) 65536) 2) + (t 8))) nil)) + (when (and payloadp should-mask) + (append mask-key nil)) + (when payloadp + (append (if should-mask (websocket-mask mask-key payload) + payload) + nil))))) + ;; We have to make sure the non-payload data is a full 32-bit frame + (if (= 1 (length val)) + (append val '(0)) val))))) + +(defun websocket-read-frame (s) + "Read from string S a `websocket-frame' struct with the contents. +This only gets complete frames. Partial frames need to wait until +the frame finishes. If the frame is not completed, return NIL." + (catch 'websocket-incomplete-frame + (websocket-ensure-length s 1) + (let* ((opcode (websocket-get-opcode s)) + (fin (logand 128 (aref s 0))) + (payloadp (memq opcode '(continuation text binary ping pong))) + (payload-len (when payloadp + (websocket-get-payload-len (substring s 1)))) + (maskp (and + payloadp + (= 128 (logand 128 (aref s 1))))) + (payload-start (when payloadp (+ (if maskp 5 1) (cdr payload-len)))) + (payload-end (when payloadp (+ payload-start (car payload-len)))) + (unmasked-payload (when payloadp + (websocket-ensure-length s payload-end) + (substring s payload-start payload-end)))) + (make-websocket-frame + :opcode opcode + :payload + (if maskp + (let ((masking-key (substring s (+ 1 (cdr payload-len)) + (+ 5 (cdr payload-len))))) + (websocket-mask masking-key unmasked-payload)) + unmasked-payload) + :length (if payloadp payload-end 1) + :completep (> fin 0))))) + +(defun websocket-format-error (err) + "Format an error message like command level does. +ERR should be a cons of error symbol and error data." + + ;; Formatting code adapted from `edebug-report-error' + (concat (or (get (car err) 'error-message) + (format "peculiar error (%s)" (car err))) + (when (cdr err) + (format ": %s" + (mapconcat #'prin1-to-string + (cdr err) ", "))))) + +(defun websocket-default-error-handler (_websocket type err) + "The default error handler used to handle errors in callbacks." + (display-warning 'websocket + (format "in callback `%S': %s" + type + (websocket-format-error err)) + :error)) + +;; Error symbols in use by the library +(put 'websocket-unsupported-protocol 'error-conditions + '(error websocket-error websocket-unsupported-protocol)) +(put 'websocket-unsupported-protocol 'error-message "Unsupported websocket protocol") +(put 'websocket-wss-needs-emacs-24 'error-conditions + '(error websocket-error websocket-unsupported-protocol + websocket-wss-needs-emacs-24)) +(put 'websocket-wss-needs-emacs-24 'error-message + "wss protocol is not supported for Emacs before version 24.") +(put 'websocket-received-error-http-response 'error-conditions + '(error websocket-error websocket-received-error-http-response)) +(put 'websocket-received-error-http-response 'error-message + "Error response received from websocket server") +(put 'websocket-invalid-header 'error-conditions + '(error websocket-error websocket-invalid-header)) +(put 'websocket-invalid-header 'error-message + "Invalid HTTP header sent") +(put 'websocket-illegal-frame 'error-conditions + '(error websocket-error websocket-illegal-frame)) +(put 'websocket-illegal-frame 'error-message + "Cannot send illegal frame to websocket") +(put 'websocket-closed 'error-conditions + '(error websocket-error websocket-closed)) +(put 'websocket-closed 'error-message + "Cannot send message to a closed websocket") +(put 'websocket-unparseable-frame 'error-conditions + '(error websocket-error websocket-unparseable-frame)) +(put 'websocket-unparseable-frame 'error-message + "Received an unparseable frame") +(put 'websocket-frame-too-large 'error-conditions + '(error websocket-error websocket-frame-too-large)) +(put 'websocket-frame-too-large 'error-message + "The frame being sent is too large for this emacs to handle") + +(defun websocket-intersect (a b) + "Simple list intersection, should function like Common Lisp's `intersection'." + (let ((result)) + (dolist (elem a (nreverse result)) + (when (member elem b) + (push elem result))))) + +(defun websocket-get-debug-buffer-create (websocket) + "Get or create the buffer corresponding to WEBSOCKET." + (let ((buf (get-buffer-create (format "*websocket %s debug*" + (websocket-url websocket))))) + (when (= 0 (buffer-size buf)) + (buffer-disable-undo buf)) + buf)) + +(defun websocket-debug (websocket msg &rest args) + "In the WEBSOCKET's debug buffer, send MSG, with format ARGS." + (when websocket-debug + (let ((buf (websocket-get-debug-buffer-create websocket))) + (save-excursion + (with-current-buffer buf + (goto-char (point-max)) + (insert "[WS] ") + (insert (apply #'format (append (list msg) args))) + (insert "\n")))))) + +(defun websocket-verify-response-code (output) + "Verify that OUTPUT contains a valid HTTP response code. +The only acceptable one to websocket is responce code 101. +A t value will be returned on success, and an error thrown +if not." + (unless (string-match "^HTTP/1.1 \\([[:digit:]]+\\)" output) + (signal 'websocket-invalid-header (list "Invalid HTTP status line"))) + (unless (equal "101" (match-string 1 output)) + (signal 'websocket-received-error-http-response + (list (string-to-number (match-string 1 output))))) + t) + +(defun websocket-parse-repeated-field (output field) + "From header-containing OUTPUT, parse out the list from a +possibly repeated field." + (let ((pos 0) + (extensions)) + (while (and pos + (string-match (format "\r\n%s: \\(.*\\)\r\n" field) + output pos)) + (when (setq pos (match-end 1)) + (setq extensions (append extensions (split-string + (match-string 1 output) ", ?"))))) + extensions)) + +(defun websocket-process-frame (websocket frame) + "Using the WEBSOCKET's filter and connection, process the FRAME. +This returns a lambda that should be executed when all frames have +been processed. If the frame has a payload, the lambda has the frame +passed to the filter slot of WEBSOCKET. If the frame is a ping, +the lambda has a reply with a pong. If the frame is a close, the lambda +has connection termination." + (let ((opcode (websocket-frame-opcode frame))) + (cond ((memq opcode '(continuation text binary)) + (lambda () (websocket-try-callback 'websocket-on-message 'on-message + websocket frame))) + ((eq opcode 'ping) + (lambda () (websocket-send websocket + (make-websocket-frame + :opcode 'pong + :payload (websocket-frame-payload frame) + :completep t)))) + ((eq opcode 'close) + (lambda () (delete-process (websocket-conn websocket)))) + (t (lambda ()))))) + +(defun websocket-process-input-on-open-ws (websocket text) + "This handles input processing for both the client and server filters." + (let ((current-frame) + (processing-queue) + (start-point 0)) + (while (setq current-frame (websocket-read-frame + (substring text start-point))) + (push (websocket-process-frame websocket current-frame) processing-queue) + (cl-incf start-point (websocket-frame-length current-frame))) + (when (> (length text) start-point) + (setf (websocket-inflight-input websocket) + (substring text start-point))) + (dolist (to-process (nreverse processing-queue)) + (funcall to-process)))) + +(defun websocket-send-text (websocket text) + "To the WEBSOCKET, send TEXT as a complete frame." + (websocket-send + websocket + (make-websocket-frame :opcode 'text + :payload (encode-coding-string + text 'raw-text) + :completep t))) + +(defun websocket-check (frame) + "Check FRAME for correctness, returning true if correct." + (or + ;; Text, binary, and continuation frames need payloads + (and (memq (websocket-frame-opcode frame) '(text binary continuation)) + (websocket-frame-payload frame)) + ;; Pings and pongs may optionally have them + (memq (websocket-frame-opcode frame) '(ping pong)) + ;; And close shouldn't have any payload, and should always be complete. + (and (eq (websocket-frame-opcode frame) 'close) + (not (websocket-frame-payload frame)) + (websocket-frame-completep frame)))) + +(defun websocket-send (websocket frame) + "To the WEBSOCKET server, send the FRAME. +This will raise an error if the frame is illegal. + +The error signaled may be of type `websocket-illegal-frame' if +the frame is malformed in some way, also having the condition +type of `websocket-error'. The data associated with the signal +is the frame being sent. + +If the websocket is closed a signal `websocket-closed' is sent, +also with `websocket-error' condition. The data in the signal is +also the frame. + +The frame may be too large for this buid of Emacs, in which case +`websocket-frame-too-large' is returned, with the data of the +size of the frame which was too large to process. This also has +the `websocket-error' condition." + (unless (websocket-check frame) + (signal 'websocket-illegal-frame (list frame))) + (websocket-debug websocket "Sending frame, opcode: %s payload: %s" + (websocket-frame-opcode frame) + (websocket-frame-payload frame)) + (unless (websocket-openp websocket) + (signal 'websocket-closed (list frame))) + (process-send-string (websocket-conn websocket) + ;; We mask only when we're a client, following the spec. + (websocket-encode-frame frame (not (websocket-server-p websocket))))) + +(defun websocket-openp (websocket) + "Check WEBSOCKET and return non-nil if the connection is open." + (and websocket + (not (eq 'close (websocket-ready-state websocket))) + (member (process-status (websocket-conn websocket)) '(open run)))) + +(defun websocket-close (websocket) + "Close WEBSOCKET and erase all the old websocket data." + (websocket-debug websocket "Closing websocket") + (websocket-try-callback 'websocket-on-close 'on-close websocket) + (when (websocket-openp websocket) + (websocket-send websocket + (make-websocket-frame :opcode 'close + :completep t)) + (setf (websocket-ready-state websocket) 'closed)) + (delete-process (websocket-conn websocket))) + +;;;;;;;;;;;;;;;;;;;;;; +;; Websocket client ;; +;;;;;;;;;;;;;;;;;;;;;; + +(cl-defun websocket-open (url &key protocols extensions (on-open 'identity) + (on-message (lambda (_w _f))) (on-close 'identity) + (on-error 'websocket-default-error-handler) + (nowait nil) (custom-header-alist nil)) + "Open a websocket connection to URL, returning the `websocket' struct. +The PROTOCOL argument is optional, and setting it will declare to +the server that this client supports the protocols in the list +given. We will require that the server also has to support that +protocols. + +Similar logic applies to EXTENSIONS, which is a list of conses, +the car of which is a string naming the extension, and the cdr of +which is the list of parameter strings to use for that extension. +The parameter strings are of the form \"key=value\" or \"value\". +EXTENSIONS can be NIL if none are in use. An example value would +be (\"deflate-stream\" . (\"mux\" \"max-channels=4\")). + +Cookies that are set via `url-cookie-store' will be used during +communication with the server, and cookies received from the +server will be stored in the same cookie storage that the +`url-cookie' package uses. + +Optionally you can specify +ON-OPEN, ON-MESSAGE and ON-CLOSE callbacks as well. + +The ON-OPEN callback is called after the connection is +established with the websocket as the only argument. The return +value is unused. + +The ON-MESSAGE callback is called after receiving a frame, and is +called with the websocket as the first argument and +`websocket-frame' struct as the second. The return value is +unused. + +The ON-CLOSE callback is called after the connection is closed, or +failed to open. It is called with the websocket as the only +argument, and the return value is unused. + +The ON-ERROR callback is called when any of the other callbacks +have an error. It takes the websocket as the first argument, and +a symbol as the second argument either `on-open', `on-message', +or `on-close', and the error as the third argument. Do NOT +rethrow the error, or else you may miss some websocket messages. +You similarly must not generate any other errors in this method. +If you want to debug errors, set +`websocket-callback-debug-on-error' to t, but this also can be +dangerous is the debugger is quit out of. If not specified, +`websocket-default-error-handler' is used. + +For each of these event handlers, the client code can store +arbitrary data in the `client-data' slot in the returned +websocket. + +The following errors might be thrown in this method or in +websocket processing, all of them having the error-condition +`websocket-error' in addition to their own symbol: + +`websocket-unsupported-protocol': Data in the error signal is the +protocol that is unsupported. For example, giving a URL starting +with http by mistake raises this error. + +`websocket-wss-needs-emacs-24': Trying to connect wss protocol +using Emacs < 24 raises this error. You can catch this error +also by `websocket-unsupported-protocol'. + +`websocket-received-error-http-response': Data in the error +signal is the integer error number. + +`websocket-invalid-header': Data in the error is a string +describing the invalid header received from the server. + +`websocket-unparseable-frame': Data in the error is a string +describing the problem with the frame. + +`nowait': If NOWAIT is true, return without waiting for the +connection to complete. + +`custom-headers-alist': An alist of custom headers to pass to the +server. The car is the header name, the cdr is the header value. +These are different from the extensions because it is not related +to the websocket protocol. +" + (let* ((name (format "websocket to %s" url)) + (url-struct (url-generic-parse-url url)) + (key (websocket-genkey)) + (coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (conn (if (member (url-type url-struct) '("ws" "wss")) + (let* ((type (if (equal (url-type url-struct) "ws") + 'plain 'tls)) + (port (if (= 0 (url-port url-struct)) + (if (eq type 'tls) 443 80) + (url-port url-struct))) + (host (url-host url-struct))) + (if (eq type 'plain) + (make-network-process :name name :buffer nil :host host + :service port :nowait nowait) + (condition-case-unless-debug nil + (open-network-stream name nil host port :type type :nowait nowait) + (wrong-number-of-arguments + (signal 'websocket-wss-needs-emacs-24 (list "wss")))))) + (signal 'websocket-unsupported-protocol (list (url-type url-struct))))) + (websocket (websocket-inner-create + :conn conn + :url url + :on-open on-open + :on-message on-message + :on-close on-close + :on-error on-error + :protocols protocols + :extensions (mapcar 'car extensions) + :accept-string + (websocket-calculate-accept key)))) + (unless conn (error "Could not establish the websocket connection to %s" url)) + (process-put conn :websocket websocket) + (set-process-filter conn + (lambda (process output) + (let ((websocket (process-get process :websocket))) + (websocket-outer-filter websocket output)))) + (set-process-sentinel + conn + (websocket-sentinel url conn key protocols extensions custom-header-alist nowait)) + (set-process-query-on-exit-flag conn nil) + (websocket-ensure-handshake url conn key protocols extensions custom-header-alist nowait) + websocket)) + +(defun websocket-sentinel (url conn key protocols extensions custom-header-alist nowait) + #'(lambda (process change) + (let ((websocket (process-get process :websocket))) + (websocket-debug websocket "State change to %s" change) + (let ((status (process-status process))) + (when (and nowait (eq status 'open)) + (websocket-ensure-handshake url conn key protocols extensions custom-header-alist nowait)) + + (when (and (member status '(closed failed exit signal)) + (not (eq 'closed (websocket-ready-state websocket)))) + (setf (websocket-ready-state websocket) 'closed) + (websocket-try-callback 'websocket-on-close 'on-close websocket)))))) + +(defun websocket-ensure-handshake (url conn key protocols extensions custom-header-alist nowait) + (let ((url-struct (url-generic-parse-url url)) + (websocket (process-get conn :websocket))) + (when (and (eq 'connecting (websocket-ready-state websocket)) + (memq (process-status conn) + (list 'run (if nowait 'connect 'open)))) + (websocket-debug websocket "Sending handshake, key: %s, acceptance: %s" + key (websocket-accept-string websocket)) + (process-send-string conn + (format "GET %s HTTP/1.1\r\n%s" + (let ((path (url-filename url-struct))) + (if (> (length path) 0) path "/")) + (websocket-create-headers + url key protocols extensions custom-header-alist)))))) + +(defun websocket-process-headers (url headers) + "On opening URL, process the HEADERS sent from the server." + (when (string-match "Set-Cookie: \(.*\)\r\n" headers) + ;; The url-current-object is assumed to be set by + ;; url-cookie-handle-set-cookie. + (let ((url-current-object (url-generic-parse-url url))) + (url-cookie-handle-set-cookie (match-string 1 headers))))) + +(defun websocket-outer-filter (websocket output) + "Filter the WEBSOCKET server's OUTPUT. +This will parse headers and process frames repeatedly until there +is no more output or the connection closes. If the websocket +connection is invalid, the connection will be closed." + (websocket-debug websocket "Received: %s" output) + (let ((start-point) + (text (concat (websocket-inflight-input websocket) output)) + (header-end-pos)) + (setf (websocket-inflight-input websocket) nil) + ;; If we've received the complete header, check to see if we've + ;; received the desired handshake. + (when (and (eq 'connecting (websocket-ready-state websocket))) + (if (and (setq header-end-pos (string-match "\r\n\r\n" text)) + (setq start-point (+ 4 header-end-pos))) + (progn + (condition-case err + (progn + (websocket-verify-response-code text) + (websocket-verify-headers websocket text) + (websocket-process-headers (websocket-url websocket) text)) + (error + (websocket-close websocket) + (funcall (websocket-on-error websocket) + websocket 'on-open err))) + (setf (websocket-ready-state websocket) 'open) + (websocket-try-callback 'websocket-on-open 'on-open websocket)) + (setf (websocket-inflight-input websocket) text))) + (when (eq 'open (websocket-ready-state websocket)) + (websocket-process-input-on-open-ws + websocket (substring text (or start-point 0)))))) + +(defun websocket-verify-headers (websocket output) + "Based on WEBSOCKET's data, ensure the headers in OUTPUT are valid. +The output is assumed to have complete headers. This function +will either return t or call `error'. This has the side-effect +of populating the list of server extensions to WEBSOCKET." + (let ((accept-regexp + (concat "Sec-Web[Ss]ocket-Accept: " (regexp-quote (websocket-accept-string websocket))))) + (websocket-debug websocket "Checking for accept header regexp: %s" accept-regexp) + (unless (string-match accept-regexp output) + (signal 'websocket-invalid-header + (list "Incorrect handshake from websocket: is this really a websocket connection?")))) + (let ((case-fold-search t)) + (websocket-debug websocket "Checking for upgrade header") + (unless (string-match "\r\nUpgrade: websocket\r\n" output) + (signal 'websocket-invalid-header + (list "No 'Upgrade: websocket' header found"))) + (websocket-debug websocket "Checking for connection header") + (unless (string-match "\r\nConnection: upgrade\r\n" output) + (signal 'websocket-invalid-header + (list "No 'Connection: upgrade' header found"))) + (when (websocket-protocols websocket) + (dolist (protocol (websocket-protocols websocket)) + (websocket-debug websocket "Checking for protocol match: %s" + protocol) + (let ((protocols + (if (string-match (format "\r\nSec-Websocket-Protocol: %s\r\n" + protocol) + output) + (list protocol) + (signal 'websocket-invalid-header + (list "Incorrect or missing protocol returned by the server."))))) + (setf (websocket-negotiated-protocols websocket) protocols)))) + (let* ((extensions (websocket-parse-repeated-field + output + "Sec-WebSocket-Extensions")) + (extra-extensions)) + (dolist (ext extensions) + (let ((x (cl-first (split-string ext "; ?")))) + (unless (or (member x (websocket-extensions websocket)) + (member x extra-extensions)) + (push x extra-extensions)))) + (when extra-extensions + (signal 'websocket-invalid-header + (list (format "Non-requested extensions returned by server: %S" + extra-extensions)))) + (setf (websocket-negotiated-extensions websocket) extensions))) + t) + +;;;;;;;;;;;;;;;;;;;;;; +;; Websocket server ;; +;;;;;;;;;;;;;;;;;;;;;; + +(defvar websocket-server-websockets nil + "A list of current websockets live on any server.") + +(cl-defun websocket-server (port &rest plist) + "Open a websocket server on PORT. +If the plist contains a `:host' HOST pair, this value will be +used to configure the addresses the socket listens on. The symbol +`local' specifies the local host. If unspecified or nil, the +socket will listen on all addresses. + +This also takes a plist of callbacks: `:on-open', `:on-message', +`:on-close' and `:on-error', which operate exactly as documented +in the websocket client function `websocket-open'. Returns the +connection, which should be kept in order to pass to +`websocket-server-close'." + (let* ((conn (make-network-process + :name (format "websocket server on port %s" port) + :server t + :family 'ipv4 + :noquery t + :filter 'websocket-server-filter + :log 'websocket-server-accept + :filter-multibyte nil + :plist plist + :host (plist-get plist :host) + :service port))) + conn)) + +(defun websocket-server-close (conn) + "Closes the websocket, as well as all open websockets for this server." + (let ((to-delete)) + (dolist (ws websocket-server-websockets) + (when (eq (websocket-server-conn ws) conn) + (if (eq (websocket-ready-state ws) 'closed) + (unless (member ws to-delete) + (push ws to-delete)) + (websocket-close ws)))) + (dolist (ws to-delete) + (setq websocket-server-websockets (remove ws websocket-server-websockets)))) + (delete-process conn)) + +(defun websocket-server-accept (server client _message) + "Accept a new websocket connection from a client." + (let ((ws (websocket-inner-create + :server-conn server + :conn client + :url client + :server-p t + :on-open (or (process-get server :on-open) 'identity) + :on-message (or (process-get server :on-message) (lambda (_ws _frame))) + :on-close (let ((user-method + (or (process-get server :on-close) 'identity))) + (lambda (ws) + (setq websocket-server-websockets + (remove ws websocket-server-websockets)) + (funcall user-method ws))) + :on-error (or (process-get server :on-error) + 'websocket-default-error-handler) + :protocols (process-get server :protocol) + :extensions (mapcar 'car (process-get server :extensions))))) + (unless (member ws websocket-server-websockets) + (push ws websocket-server-websockets)) + (process-put client :websocket ws) + (set-process-coding-system client 'binary 'binary) + (set-process-sentinel client + (lambda (process change) + (let ((websocket (process-get process :websocket))) + (websocket-debug websocket "State change to %s" change) + (when (and + (member (process-status process) '(closed failed exit signal)) + (not (eq 'closed (websocket-ready-state websocket)))) + (websocket-try-callback 'websocket-on-close 'on-close websocket))))))) + +(defun websocket-create-headers (url key protocol extensions custom-headers-alist) + "Create connections headers for the given URL, KEY, PROTOCOL, and EXTENSIONS. +Additionally, the CUSTOM-HEADERS-ALIST is passed from the client. +All these parameters are defined as in `websocket-open'." + (let* ((parsed-url (url-generic-parse-url url)) + (host-port (if (url-port-if-non-default parsed-url) + (format "%s:%s" (url-host parsed-url) (url-port parsed-url)) + (url-host parsed-url))) + (cookie-header (url-cookie-generate-header-lines + host-port (car (url-path-and-query parsed-url)) + (equal (url-type parsed-url) "wss")))) + (concat + (format (concat "Host: %s\r\n" + "Upgrade: websocket\r\n" + "Connection: Upgrade\r\n" + "Sec-WebSocket-Key: %s\r\n" + "Sec-WebSocket-Version: 13\r\n" + (when protocol + (concat + (mapconcat + (lambda (protocol) + (format "Sec-WebSocket-Protocol: %s" protocol)) + protocol "\r\n") + "\r\n")) + (when extensions + (format "Sec-WebSocket-Extensions: %s\r\n" + (mapconcat + (lambda (ext) + (concat + (car ext) + (when (cdr ext) "; ") + (when (cdr ext) + (mapconcat 'identity (cdr ext) "; ")))) + extensions ", ")))) + host-port + key + protocol) + (when cookie-header cookie-header) + (mapconcat (lambda (cons) (format "%s: %s" (car cons) (cdr cons))) + custom-headers-alist "\r\n") + (when custom-headers-alist "\r\n") + "\r\n"))) + +(defun websocket-get-server-response (websocket client-protocols client-extensions) + "Get the websocket response from client WEBSOCKET." + (let ((separator "\r\n")) + (concat "HTTP/1.1 101 Switching Protocols" separator + "Upgrade: websocket" separator + "Connection: Upgrade" separator + "Sec-WebSocket-Accept: " + (websocket-accept-string websocket) separator + (let ((protocols + (websocket-intersect client-protocols + (websocket-protocols websocket)))) + (when protocols + (concat + (mapconcat + (lambda (protocol) (format "Sec-WebSocket-Protocol: %s" + protocol)) protocols separator) + separator))) + (let ((extensions (websocket-intersect + client-extensions + (websocket-extensions websocket)))) + (when extensions + (concat + (mapconcat + (lambda (extension) (format "Sec-Websocket-Extensions: %s" + extension)) extensions separator) + separator))) + separator))) + +(defun websocket-server-filter (process output) + "This acts on all OUTPUT from websocket clients PROCESS." + (let* ((ws (process-get process :websocket)) + (text (concat (websocket-inflight-input ws) output))) + (setf (websocket-inflight-input ws) nil) + (cond ((eq (websocket-ready-state ws) 'connecting) + ;; check for connection string + (let ((end-of-header-pos + (let ((pos (string-match "\r\n\r\n" text))) + (when pos (+ 4 pos))))) + (if end-of-header-pos + (progn + (let ((header-info (websocket-verify-client-headers text))) + (if header-info + (progn (setf (websocket-accept-string ws) + (websocket-calculate-accept + (plist-get header-info :key))) + (process-send-string + process + (websocket-get-server-response + ws (plist-get header-info :protocols) + (plist-get header-info :extensions))) + (setf (websocket-ready-state ws) 'open) + (setf (websocket-origin ws) (plist-get header-info :origin)) + (websocket-try-callback 'websocket-on-open + 'on-open ws)) + (message "Invalid client headers found in: %s" output) + (process-send-string process "HTTP/1.1 400 Bad Request\r\n\r\n") + (websocket-close ws))) + (when (> (length text) (+ 1 end-of-header-pos)) + (websocket-server-filter process (substring + text + end-of-header-pos)))) + (setf (websocket-inflight-input ws) text)))) + ((eq (websocket-ready-state ws) 'open) + (websocket-process-input-on-open-ws ws text)) + ((eq (websocket-ready-state ws) 'closed) + (message "WARNING: Should not have received further input on closed websocket"))))) + +(defun websocket-verify-client-headers (output) + "Verify the headers from the WEBSOCKET client connection in OUTPUT. +Unlike `websocket-verify-headers', this is a quieter routine. We +don't want to error due to a bad client, so we just print out +messages and a plist containing `:key', the websocket key, +`:protocols' and `:extensions'." + (cl-block nil + (let ((case-fold-search t) + (plist)) + (unless (string-match "HTTP/1.1" output) + (message "Websocket client connection: HTTP/1.1 not found") + (cl-return nil)) + (unless (string-match "^Host: " output) + (message "Websocket client connection: Host header not found") + (cl-return nil)) + (unless (string-match "^Upgrade: websocket\r\n" output) + (message "Websocket client connection: Upgrade: websocket not found") + (cl-return nil)) + (if (string-match "^Sec-WebSocket-Key: \\([[:graph:]]+\\)\r\n" output) + (setq plist (plist-put plist :key (match-string 1 output))) + (message "Websocket client connect: No key sent") + (cl-return nil)) + (unless (string-match "^Sec-WebSocket-Version: 13" output) + (message "Websocket client connect: Websocket version 13 not found") + (cl-return nil)) + (when (string-match "^Sec-WebSocket-Protocol:" output) + (setq plist (plist-put plist :protocols (websocket-parse-repeated-field + output + "Sec-Websocket-Protocol")))) + (when (string-match "^Sec-WebSocket-Extensions:" output) + (setq plist (plist-put plist :extensions (websocket-parse-repeated-field + output + "Sec-Websocket-Extensions")))) + (when (string-match "^Origin: \\(.+\\)\r\n" output) + (setq plist (plist-put plist :origin (match-string 1 output)))) + plist))) + +(provide 'websocket) + +;;; websocket.el ends here blob - /dev/null blob + 7a028e4689ac2c267684cb8cf1e30ddd32bf1fb1 (mode 644) --- /dev/null +++ elpa/websocket-1.15.signed @@ -0,0 +1 @@ +Good signature from 645357D2883A0966 GNU ELPA Signing Agent (2023) (trust undefined) created at 2024-04-24T11:10:03+0200 using EDDSA \ No newline at end of file blob - a51f28cdb5078478b7ad0785e614e8ea2b5ea5a3 blob + 56eff425ac1fa578d83a6663d07d0c96e024ed33 --- init.el +++ init.el @@ -325,7 +325,16 @@ '(cursor-type 'bar) '(custom-enabled-themes '(modus-operandi)) '(custom-safe-themes - '("1ea82e39d89b526e2266786886d1f0d3a3fa36c87480fad59d8fab3b03ef576e" "3d94d6d1a1c23113a60c8496c9aed094dbc2695f219e8127bb168d17b1e6dab3" "4b026ac68a1aa4d1a91879b64f54c2490b4ecad8b64de5b1865bca0addd053d9" "58264887d7ab17702ef85bbd96e11bd7f613622ff9c63990be860b958c978f09" "611ef0918b8b413badb8055089b5499c1d4ac20f1861efba8f3bfcb36ad0a448" "15604b083d03519b0c2ed7b32da6d7b2dc2f6630bef62608def60cdcf9216184" "88cb0f9c0c11dbb4c26a628d35eb9239d1cf580cfd28e332e654e7f58b4e721b" "69f7e8101867cfac410e88140f8c51b4433b93680901bb0b52014144366a08c8" "21e3d55141186651571241c2ba3c665979d1e886f53b2e52411e9e96659132d4" default)) + '("1ea82e39d89b526e2266786886d1f0d3a3fa36c87480fad59d8fab3b03ef576e" + "3d94d6d1a1c23113a60c8496c9aed094dbc2695f219e8127bb168d17b1e6dab3" + "4b026ac68a1aa4d1a91879b64f54c2490b4ecad8b64de5b1865bca0addd053d9" + "58264887d7ab17702ef85bbd96e11bd7f613622ff9c63990be860b958c978f09" + "611ef0918b8b413badb8055089b5499c1d4ac20f1861efba8f3bfcb36ad0a448" + "15604b083d03519b0c2ed7b32da6d7b2dc2f6630bef62608def60cdcf9216184" + "88cb0f9c0c11dbb4c26a628d35eb9239d1cf580cfd28e332e654e7f58b4e721b" + "69f7e8101867cfac410e88140f8c51b4433b93680901bb0b52014144366a08c8" + "21e3d55141186651571241c2ba3c665979d1e886f53b2e52411e9e96659132d4" + default)) '(delete-old-versions t) '(delete-selection-mode t) '(denote-modules '(project xref ffap)) @@ -337,8 +346,7 @@ '(display-buffer-alist '(("\\\\*sly-db for" (display-buffer-reuse-window display-buffer-below-selected) - (dedicated . t) - (window-height . 0.3)) + (dedicated . t) (window-height . 0.3)) ("\\\\*Async Shell Command\\\\*" display-buffer-no-window))) '(ediff-split-window-function 'split-window-horizontally) '(ediff-window-setup-function 'ediff-setup-windows-plain) @@ -354,7 +362,7 @@ '(global-diff-hl-mode t) '(help-window-select t) '(ibuffer-mode-hook '(all-the-icons-ibuffer-mode)) - '(ignored-local-variable-values '((sly-load-failed-fasl . ask))) + '(ignored-local-variable-values '((Package . SIMPLE-DATE) (sly-load-failed-fasl . ask))) '(indent-tabs-mode nil) '(inferior-lisp-program "sbcl") '(kept-new-versions 10) @@ -366,17 +374,15 @@ '(mouse-wheel-scroll-amount '(5 ((shift) . hscroll) ((meta)) ((control) . text-scale))) '(notmuch-archive-tags '("-inbox" "-unread")) '(org-agenda-custom-commands - '(("n" "Agenda and all TODOs" - ((agenda "" nil) - (alltodo "" nil)) - nil) + '(("n" "Agenda and all TODOs" ((agenda "" nil) (alltodo "" nil)) nil) ("g" "GTD View" ((agenda "" nil) (tags-todo "+aktion+TODO=\"NEXT\"" ((org-agenda-overriding-header "Nächste Aktionen:"))) (tags "projekt" ((org-agenda-overriding-header "Projekte:") - (org-agenda-skip-function 'lh/org-capture-skip-below-toplevel))) + (org-agenda-skip-function + 'lh/org-capture-skip-below-toplevel))) (tags-todo "WAITING" ((org-agenda-overriding-header "Warten auf:")))) nil nil))) @@ -391,10 +397,7 @@ '(org-startup-indented t) '(org-startup-truncated nil) '(package-archive-priorities - '(("gnu" . 3) - ("nongnu" . 2) - ("melpa-stable" . 1) - ("melpa" . 0))) + '(("gnu" . 3) ("nongnu" . 2) ("melpa-stable" . 1) ("melpa" . 0))) '(package-archives '(("gnu" . "https://elpa.gnu.org/packages/") ("nongnu" . "https://elpa.nongnu.org/nongnu/") @@ -402,8 +405,20 @@ ("melpa" . "https://melpa.org/packages/"))) '(package-pinned-packages '((sly . "melpa"))) '(package-selected-packages - '(notmuch substitute highlight-function-calls prism modus-themes imenu-list diff-hl embark-consult embark all-the-icons-completion all-the-icons-ibuffer all-the-icons-dired sly-named-readtables sly-macrostep denote-refs denote-menu denote ox-epub ob-powershell powershell web-mode lexic editorconfig elfeed-tube-mpv elfeed-tube restclient-jq graphviz-dot-mode consult-eglot jq-mode ob-restclient restclient deadgrep helpful pdf-tools paredit-menu paredit corfu sly eglot aggressive-indent project nov nhexl-mode elfeed magit yaml-mode json-mode lua-mode go-mode org-contrib org ace-window expand-region consult marginalia uuidgen diminish which-key)) - '(pcomplete-ignore-case t t) + '(ace-window aggressive-indent all-the-icons-completion + all-the-icons-dired all-the-icons-ibuffer + atomic-chrome consult consult-eglot corfu deadgrep + denote denote-menu denote-refs diff-hl diminish + editorconfig eglot elfeed elfeed-tube elfeed-tube-mpv + embark embark-consult expand-region go-mode + graphviz-dot-mode helpful highlight-function-calls + imenu-list jq-mode json-mode lexic lua-mode magit + marginalia modus-themes nhexl-mode notmuch nov + ob-powershell ob-restclient org org-contrib ox-epub + paredit paredit-menu pdf-tools powershell prism + project restclient restclient-jq sly sly-macrostep + sly-named-readtables substitute uuidgen web-mode + which-key yaml-mode)) '(pixel-scroll-precision-mode t) '(prism-parens t) '(read-buffer-completion-ignore-case t)