├── read.lisp ├── .gitignore ├── protocol-common.lisp ├── package.lisp ├── clws.asd ├── util.lisp ├── sb-concurrency-patch.lisp ├── config.lisp ├── concurrency-sbcl.lisp ├── html ├── chat.html └── echo.html ├── concurrency-chanl.lisp ├── examples └── resource-examples.lisp ├── protocol-00.lisp ├── server.lisp ├── README.md ├── test.lisp ├── resource.lisp ├── protocol-7.lisp ├── protocol.lisp ├── buffer.lisp └── client.lisp /read.lisp: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *~ 3 | \#* 4 | .\#* -------------------------------------------------------------------------------- /protocol-common.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | (defparameter *supported-protocol-versions* '()) 4 | (defparameter *protocol-header-parsers* (make-hash-table :test #'equalp)) 5 | 6 | (defun get-utf8-string-or-fail (chunk-buffer &key skip-octets-end) 7 | (handler-case 8 | (if skip-octets-end 9 | (get-utf8-string chunk-buffer :octet-end (- (buffer-size chunk-buffer) 10 | skip-octets-end)) 11 | (get-utf8-string chunk-buffer)) 12 | (flexi-streams:external-format-encoding-error () 13 | (error 'fail-the-websockets-connection 14 | :status-code 1007 15 | :message "invalid UTF-8")) 16 | (babel:character-coding-error () 17 | (error 'fail-the-websockets-connection 18 | :status-code 1007 19 | :message "invalid UTF-8")))) 20 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:clws 2 | (:nicknames #:ws) 3 | (:use #:cl #:iolib) 4 | (:export 5 | ;; client 6 | #:write-to-client-text 7 | #:write-to-client-binary 8 | #:write-to-clients-text 9 | #:write-to-clients-binary 10 | #:write-to-client-close 11 | #:write-to-client-ping 12 | #:client-host 13 | #:client-port 14 | #:client-resource-name 15 | #:client-query-string 16 | #:client-connection-headers 17 | #:client-websocket-version 18 | 19 | #:client-connection-rejected 20 | ;; resource 21 | #:ws-resource 22 | #:register-global-resource 23 | #:find-global-resource 24 | #:unregister-global-resource 25 | #:resource-received-text 26 | #:resource-received-binary 27 | #:resource-received-pong 28 | #:resource-client-connected 29 | #:resource-client-disconnected 30 | #:run-resource-listener 31 | #:kill-resource-listener 32 | 33 | #:resource-accept-connection 34 | #:send-custom-message-to-resource 35 | #:send-custom-message-to-resource 36 | #:call-on-resource-thread 37 | ;; server 38 | #:run-server 39 | #:*debug-on-server-errors* 40 | #:*debug-on-resource-errors* 41 | #:*protocol-76/00-support* 42 | #:*max-clients* 43 | #:*max-read-frame-size* 44 | #:origin-prefix 45 | #:any-origin 46 | #:origin-exact 47 | 48 | #:*log-level*)) 49 | 50 | (in-package :clws) 51 | 52 | -------------------------------------------------------------------------------- /clws.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package :cl-user) 2 | 3 | (defpackage :clws-system 4 | (:use #:cl #:asdf)) 5 | 6 | (in-package :clws-system) 7 | 8 | (defsystem :clws 9 | :depends-on (#+sbcl "sb-concurrency" 10 | #-sbcl "chanl" 11 | "iolib" 12 | "ironclad" 13 | "chunga" ; for o7 hanshake 14 | "cl-base64" ; for o7 hanshake 15 | "flexi-streams" 16 | "split-sequence") 17 | :serial t 18 | :components ((:file "package") 19 | #+sbcl(:file "sb-concurrency-patch") 20 | #+sbcl(:file "concurrency-sbcl") 21 | #-sbcl(:file "concurrency-chanl") 22 | (:file "util") 23 | (:file "config") 24 | (:file "buffer") 25 | (:file "protocol-common") 26 | (:file "protocol-00") 27 | (:file "protocol-7") 28 | (:file "protocol") 29 | (:file "client") 30 | (:file "resource") 31 | (:file "server")) 32 | :license "MIT" 33 | :author "Bart Botta <00003b at gmail.com>" 34 | :description "CLWS implement the WebSocket Protocol as described by 35 | RFC6455[1] (as well as some older drafts implemented by recent 36 | browsers [2][3][4][5]). Only a WebSockets server implementation is 37 | provided. 38 | 39 | [1]http://tools.ietf.org/html/rfc6455 40 | [2] http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-17 41 | [3] http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-08 42 | [4] http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07 43 | [5] http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-00") 44 | 45 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | (defun string-to-shareable-octets (string &key (encoding babel:*default-character-encoding*) 4 | (start 0) end (use-bom :default) 5 | (errorp (not babel::*suppress-character-coding-errors*))) 6 | #+lispworks 7 | (sys:in-static-area 8 | (babel:string-to-octets string :encoding encoding 9 | :start start 10 | :end end 11 | :use-bom use-bom 12 | :errorp errorp)) 13 | #-lispworks 14 | (babel:string-to-octets string :encoding encoding 15 | :start start 16 | :end end 17 | :use-bom use-bom 18 | :errorp errorp)) 19 | 20 | (defun make-domain-policy (&key (from "*") (to-port "*")) 21 | "Generates a very basic cross-domain policy file, used for the 22 | WebSocket emulation via Flash. 23 | 24 | For more information on what that is, see 25 | http://www.adobe.com/devnet/articles/crossdomain_policy_file_spec.html" 26 | (string-to-shareable-octets 27 | (format nil " 28 | 29 | ~c" 30 | from to-port 31 | (code-char 0)) 32 | :encoding :ascii)) 33 | 34 | (defun lg (&rest args) 35 | (declare (special *log-level*)) 36 | (when *log-level* 37 | (apply #'format t args) 38 | (finish-output))) 39 | 40 | (defmacro make-array-ubyte8 (size &key (initial-element nil initial-element-p) 41 | (initial-contents nil initial-contents-p)) 42 | (let ((body `(make-array ,size :element-type '(unsigned-byte 8) 43 | #+(and lispworks (not (or lispworks3 lispworks4 lispworks5.0))) 44 | ,@`(:allocation :static) 45 | ,@(when initial-element-p `(:initial-element ,initial-element)) 46 | ,@(when initial-contents-p `(:initial-contents ,initial-contents))))) 47 | #+(or lispworks3 lispworks4 lispworks5.0) 48 | `(sys:in-static-area 49 | ,body) 50 | #-(or lispworks3 lispworks4 lispworks5.0) 51 | body 52 | )) 53 | -------------------------------------------------------------------------------- /sb-concurrency-patch.lisp: -------------------------------------------------------------------------------- 1 | #+sbcl 2 | (in-package :sb-concurrency) 3 | 4 | ;;; included upstream in 1.0.42.19, so only load on older versions 5 | #+sbcl 6 | (when (destructuring-bind (maj min point &rest r) 7 | (split-sequence:split-sequence #\. (lisp-implementation-version)) 8 | (declare (ignore r)) 9 | (and (string= maj "1") (string= min "0") 10 | (and point (<= 37 (parse-integer point :junk-allowed t) 42)))) 11 | ;;; break up links when removing nodes to avoid problems with conservative 12 | ;;; GC in long-lived queues 13 | (defun dequeue (queue) 14 | "Retrieves the oldest value in QUEUE and returns it as the primary value, 15 | and T as secondary value. If the queue is empty, returns NIL as both primary 16 | and secondary value." 17 | (tagbody 18 | :continue 19 | (let* ((head (queue-head queue)) 20 | (tail (queue-tail queue)) 21 | (first-node-prev (node-prev head)) 22 | (val (node-value head))) 23 | (when (eq head (queue-head queue)) 24 | (cond ((not (eq val +dummy+)) 25 | (if (eq tail head) 26 | (let ((dummy (make-node :value +dummy+ :next tail))) 27 | (when (eq tail (sb-ext:compare-and-swap (queue-tail queue) 28 | tail dummy)) 29 | (setf (node-prev head) dummy)) 30 | (go :continue)) 31 | (when (null first-node-prev) 32 | (fixList queue tail head) 33 | (go :continue))) 34 | (when (eq head (sb-ext:compare-and-swap (queue-head queue) 35 | head first-node-prev)) 36 | ;; This assignment is not present in the paper, but is 37 | ;; equivalent to the free(head.ptr) call there: it unlinks 38 | ;; the HEAD from the queue -- the code in the paper leaves 39 | ;; the dangling pointer in place. 40 | (setf (node-next first-node-prev) nil) 41 | (setf (node-prev head) nil 42 | (node-next head) nil) 43 | (return-from dequeue (values val t)))) 44 | ((eq tail head) 45 | (return-from dequeue (values nil nil))) 46 | ((null first-node-prev) 47 | (fixList queue tail head) 48 | (go :continue)) 49 | (t 50 | (sb-ext:compare-and-swap (queue-head queue) 51 | head first-node-prev))))) 52 | (go :continue)))) -------------------------------------------------------------------------------- /config.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | ;;; some of these should probably be per resource handler rather than global? 4 | 5 | (defvar *protocol-76/00-support* nil 6 | "set to NIL to disable draft-hixie-76/draft-ietf-00 support, true to enable.") 7 | 8 | (defvar *max-clients* 256 9 | "Max number of simultaneous clients allowed (nil for no limit). 10 | Extra connections will get a HTTP 5xx response (without reading headers).") 11 | 12 | (defvar *max-read-frame-size* (* 16 (expt 2 20)) 13 | "Max size of frames allowed. Connection will be dropped if client sends 14 | a larger frame.") 15 | 16 | ;;; firefox defaults to ~16MB and Autobahn tests test up to 16MB as well 17 | ;;; probably should be lower for production servers, until there is 18 | ;;; some sort of aggregate limit to prevent a few hundred connections 19 | ;;; from buffering 16MB each 20 | (defvar *max-read-message-size* (* 16 (expt 2 20)) 21 | "Largest (incomplete) message allowed. Connection will be dropped if 22 | client sends a larger message. Malicious clients can cause lower amounts 23 | to be buffered indefinitely though, so be careful with large settings.") 24 | 25 | (defvar *max-header-size* 16384 26 | "Default max header size in octets (not used yet?)") 27 | 28 | ;; fixme: should this have a separate setting for when to reenable readers? 29 | (defvar *max-handler-read-backlog* 4 30 | "Max number of frames that can be queued before the reader will 31 | start throttling reads for clients using that queue (for now, just 32 | drops the connections...).") 33 | 34 | (defvar *policy-file* (make-domain-policy :from "*" :to-port "*") 35 | "cross-domain policy file, used for the Flash WebSocket emulator.") 36 | 37 | (defvar *log-level* nil 38 | ;; todo: intermediate settings 39 | "set to NIL to disable log messages, T to enable") 40 | 41 | (defvar *debug-on-server-errors* nil 42 | "set to T to enter debugger on server errors, NIL to just drop the connections.") 43 | 44 | (defvar *debug-on-resource-errors* nil 45 | "set to T to enter debugger on resource-handler errors, NIL to drop the connections and try to send a disconnect to handler.") 46 | 47 | ;; RFC-compliant CRLF sequence for HTTP/1.1 status and header lines 48 | (defparameter +crlf+ (coerce (list #\Return #\Linefeed) 'string)) 49 | 50 | 51 | (defvar *400-message* 52 | (string-to-shareable-octets 53 | (format nil "HTTP/1.1 400 Bad Request~A~A" +crlf+ +crlf+) 54 | :encoding :utf-8)) 55 | 56 | (defvar *403-message* 57 | (string-to-shareable-octets 58 | (format nil "HTTP/1.1 403 Forbidden~A~A" +crlf+ +crlf+) 59 | :encoding :utf-8)) 60 | 61 | (defvar *404-message* 62 | (string-to-shareable-octets 63 | (format nil "HTTP/1.1 404 Resource not found~A~A" +crlf+ +crlf+) 64 | :encoding :utf-8)) 65 | 66 | -------------------------------------------------------------------------------- /concurrency-sbcl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:clws) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;;; Queues 5 | ;;;; Thread safe queue 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | (defun make-queue (&key name initial-contents) 8 | "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS 9 | sequence enqueued." 10 | #+sbcl 11 | (sb-concurrency:make-queue :name name :initial-contents initial-contents)) 12 | 13 | (defun enqueue (value queue) 14 | "Adds VALUE to the end of QUEUE. Returns VALUE." 15 | #+sbcl 16 | (sb-concurrency:enqueue value queue)) 17 | 18 | (defun dequeue (queue) 19 | "Retrieves the oldest value in QUEUE and returns it as the primary value, 20 | and T as secondary value. If the queue is empty, returns NIL as both primary 21 | and secondary value." 22 | (sb-concurrency:dequeue queue)) 23 | 24 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 25 | ;;;; Mailboxes 26 | ;;;; Thread safe queue with ability to do blocking reads 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | (defun make-mailbox (&key name initial-contents) 29 | "Returns a new MAILBOX with messages in INITIAL-CONTENTS enqueued." 30 | #+sbcl 31 | (sb-concurrency:make-mailbox :name name :initial-contents initial-contents)) 32 | 33 | (defun mailboxp (mailbox) 34 | "Returns true if MAILBOX is currently empty, NIL otherwise." 35 | #+sbcl 36 | (sb-concurrency:mailboxp mailbox)) 37 | 38 | (defun mailbox-empty-p (mailbox) 39 | "Returns true if MAILBOX is currently empty, NIL otherwise." 40 | #+sbcl 41 | (sb-concurrency:mailbox-empty-p mailbox)) 42 | 43 | (defun mailbox-send-message (mailbox message) 44 | "Adds a MESSAGE to MAILBOX. Message can be any object." 45 | #+sbcl 46 | (sb-concurrency:send-message mailbox message) 47 | #-sbcl 48 | (error "Not implemented")) 49 | 50 | (defun mailbox-receive-message (mailbox &key) 51 | "Removes the oldest message from MAILBOX and returns it as the 52 | primary value. If MAILBOX is empty waits until a message arrives." 53 | #+sbcl 54 | (sb-concurrency:receive-message mailbox)) 55 | 56 | (defun mailbox-receive-message-no-hang (mailbox) 57 | "The non-blocking variant of RECEIVE-MESSAGE. Returns two values, 58 | the message removed from MAILBOX, and a flag specifying whether a 59 | message could be received." 60 | #+sbcl 61 | (sb-concurrency:receive-message-no-hang mailbox)) 62 | 63 | (defun mailbox-count (mailbox) 64 | "The non-blocking variant of RECEIVE-MESSAGE. Returns two values, 65 | the message removed from MAILBOX, and a flag specifying whether a 66 | message could be received." 67 | #+sbcl 68 | (sb-concurrency:mailbox-count mailbox)) 69 | 70 | (defun mailbox-list-messages (mailbox) 71 | "Returns a fresh list containing all the messages in the 72 | mailbox. Does not remove messages from the mailbox." 73 | #+sbcl 74 | (sb-concurrency:list-mailbox-messages mailbox)) 75 | 76 | (defun mailbox-receive-pending-messages (mailbox &optional n) 77 | "Removes and returns all (or at most N) currently pending messages 78 | from MAILBOX, or returns NIL if no messages are pending. 79 | 80 | Note: Concurrent threads may be snarfing messages during the run of 81 | this function, so even though X,Y appear right next to each other in 82 | the result, does not necessarily mean that Y was the message sent 83 | right after X." 84 | #+sbcl 85 | (sb-concurrency:receive-pending-messages mailbox n)) 86 | 87 | 88 | 89 | 90 | -------------------------------------------------------------------------------- /html/chat.html: -------------------------------------------------------------------------------- 1 | 2 | 7 | 8 | 9 | 10 | Sample of web_socket.js 11 | 12 | 13 | 14 | 15 | 16 | 99 | 100 |
101 | 102 | 103 | 104 | 105 |
106 |
107 | 108 | -------------------------------------------------------------------------------- /html/echo.html: -------------------------------------------------------------------------------- 1 | 2 | 7 | 8 | 9 | 10 | Sample of web_socket.js 11 | 12 | 13 | 14 | 15 | 16 | 100 | 101 |
102 | 103 | 104 | 105 | 106 |
107 |
108 | 109 | -------------------------------------------------------------------------------- /concurrency-chanl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:clws) 2 | 3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4 | ;;;; Queues 5 | ;;;; Thread safe queue 6 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 | (defun make-queue (&key name initial-contents) 8 | "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS 9 | sequence enqueued." 10 | (declare (ignorable name)) 11 | (let ((c (make-instance 'chanl:unbounded-channel))) 12 | (loop for i on initial-contents 13 | do (chanl:send c i)) 14 | c)) 15 | 16 | (defun enqueue (value queue) 17 | "Adds VALUE to the end of QUEUE. Returns VALUE." 18 | (chanl:send queue value)) 19 | 20 | (defun dequeue (queue) 21 | "Retrieves the oldest value in QUEUE and returns it as the primary value, 22 | and T as secondary value. If the queue is empty, returns NIL as both primary 23 | and secondary value." 24 | ;; fixme: doesn't actually return T for second value, returns the queue 25 | ;; determine if that matters and either fix it or change docstring 26 | (chanl:recv queue :blockp nil)) 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;;; Mailboxes 30 | ;;;; Thread safe queue with ability to do blocking reads 31 | ;;;; and get count of currently queueud items 32 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 33 | #+sbcl 34 | (defstruct atomic-place 35 | (val 0 :type (unsigned-byte #+x86-64 64 #+x86 32))) 36 | #+(or ccl lispworks) 37 | (defun make-atomic-place (&key val) 38 | val) 39 | 40 | (defun make-mailbox (&key name initial-contents) 41 | "Returns a new MAILBOX with messages in INITIAL-CONTENTS enqueued." 42 | (cons 43 | (make-atomic-place :val (length initial-contents)) 44 | (make-queue :name name :initial-contents initial-contents))) 45 | 46 | #++ 47 | (defun mailboxp (mailbox) 48 | "Returns true if MAILBOX is currently empty, NIL otherwise." 49 | (chanl:channelp mailbox)) 50 | 51 | (defun mailbox-empty-p (mailbox) 52 | "Returns true if MAILBOX is currently empty, NIL otherwise." 53 | (zerop (mailbox-count mailbox))) 54 | 55 | (defun mailbox-send-message (mailbox message) 56 | "Adds a MESSAGE to MAILBOX. Message can be any object." 57 | #- (or ccl sbcl lispworks) 58 | (error "not implemented") 59 | (progn 60 | #+ccl (ccl::atomic-incf (car mailbox)) 61 | #+sbcl (sb-ext:atomic-incf (atomic-place-val (car mailbox))) 62 | #+lispworks (system:atomic-incf (car mailbox)) 63 | (chanl:send (cdr mailbox) message))) 64 | 65 | (defun mailbox-receive-message (mailbox &key) 66 | "Removes the oldest message from MAILBOX and returns it as the 67 | primary value. If MAILBOX is empty waits until a message arrives." 68 | #- (or ccl sbcl lispworks) 69 | (error "not implemented") 70 | (prog1 71 | (chanl:recv (cdr mailbox)) 72 | #+sbcl (sb-ext:atomic-decf (atomic-place-val (car mailbox))) 73 | #+ccl (ccl::atomic-decf (car mailbox)) 74 | #+lispworks (system:atomic-decf (car mailbox)))) 75 | 76 | (defun mailbox-receive-message-no-hang (mailbox) 77 | "The non-blocking variant of RECEIVE-MESSAGE. Returns two values, 78 | the message removed from MAILBOX, and a flag specifying whether a 79 | message could be received." 80 | #- (or ccl sbcl lispworks) 81 | (error "not implemented") 82 | (multiple-value-bind (message found) 83 | (chanl:recv (cdr mailbox) :blockp nil) 84 | (when found 85 | #+sbcl (sb-ext:atomic-decf (atomic-place-val (car mailbox))) 86 | #+ccl (ccl::atomic-decf (car mailbox)) 87 | #+lispworks (system:atomic-decf (car mailbox))) 88 | (values message found))) 89 | 90 | (defun mailbox-count (mailbox) 91 | "The non-blocking variant of RECEIVE-MESSAGE. Returns two values, 92 | the message removed from MAILBOX, and a flag specifying whether a 93 | message could be received." 94 | #+sbcl (atomic-place-val (car mailbox)) 95 | #-sbcl (car mailbox)) 96 | 97 | (defun mailbox-list-messages (mailbox) 98 | "Returns a fresh list containing all the messages in the 99 | mailbox. Does not remove messages from the mailbox." 100 | (declare (ignore mailbox)) 101 | (error "not implemented")) 102 | 103 | (defun mailbox-receive-pending-messages (mailbox &optional n) 104 | "Removes and returns all (or at most N) currently pending messages 105 | from MAILBOX, or returns NIL if no messages are pending. 106 | 107 | Note: Concurrent threads may be snarfing messages during the run of 108 | this function, so even though X,Y appear right next to each other in 109 | the result, does not necessarily mean that Y was the message sent 110 | right after X." 111 | (loop with msg = nil 112 | with found = nil 113 | for i from 0 114 | while (or (not n) (< i n)) 115 | do (setf (values msg found) (mailbox-receive-message-no-hang mailbox)) 116 | while found 117 | collect msg)) 118 | 119 | -------------------------------------------------------------------------------- /examples/resource-examples.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | ;;;; Echo server 4 | ;;;; ----------- 5 | 6 | (defclass echo-resource (ws-resource) 7 | ((ping-times :initform (make-hash-table :test 'equal) :accessor ping-times))) 8 | 9 | (register-global-resource 10 | "/echo" 11 | (make-instance 'echo-resource) 12 | (ws::origin-prefix "http://127.0.0.1" "http://localhost" "null")) 13 | 14 | #++ 15 | (defmethod resource-accept-connection ((res echo-resource) resource-name headers client) 16 | (declare (ignore headers resource-name)) 17 | (format t "got connection on echo server from ~s : ~s~%" (client-host client) (client-port client)) 18 | t) 19 | 20 | (defmethod resource-client-connected ((res echo-resource) client) 21 | (format t "got connection on echo server from ~s : ~s~%" (client-host client) (client-port client)) 22 | t) 23 | 24 | (defmethod resource-client-disconnected ((resource echo-resource) client) 25 | (format t "Client disconnected from resource ~A: ~A~%" resource client)) 26 | 27 | (defmethod resource-received-text ((res echo-resource) client message) 28 | #++(format t "got frame ~s from client ~s" message client) 29 | (when (string= message "error") 30 | (error "got \"error\" message ")) 31 | ;; Test ping functionality - if message is "ping", send a ping frame with timestamp 32 | (when (string= message "ping") 33 | (let ((timestamp (get-universal-time))) 34 | (format t "Sending ping to client ~s at time ~s~%" client timestamp) 35 | ;; Store the ping time with the payload as key 36 | (setf (gethash (format nil "~d" timestamp) (ping-times res)) timestamp) 37 | (write-to-client-ping client (format nil "~d" timestamp)))) 38 | (write-to-client-text client message)) 39 | 40 | (defmethod resource-received-binary((res echo-resource) client message) 41 | #++(format t "got binary frame ~s from client ~s" (length message) client) 42 | #++ (write-to-client-text client (format nil "got binary ~s" message)) 43 | (write-to-client-binary client message)) 44 | 45 | (defmethod resource-received-pong ((res echo-resource) client message) 46 | "Handle pong frames for latency measurement" 47 | (let* ((payload-str (if (vectorp message) 48 | (babel:octets-to-string message :encoding :utf-8) 49 | (format nil "~s" message))) 50 | (send-time (gethash payload-str (ping-times res))) 51 | (current-time (get-universal-time))) 52 | (if send-time 53 | (let ((latency (- current-time send-time))) 54 | (format t "Pong received from client ~s. Latency: ~d seconds~%" client latency) 55 | (remhash payload-str (ping-times res)) 56 | ;; Send latency measurement back to client 57 | (write-to-client-text client (format nil "Latency: ~d seconds" latency))) 58 | (format t "Pong received from client ~s with unknown payload: ~s~%" client payload-str)))) 59 | 60 | 61 | #++ 62 | (bordeaux-threads:make-thread 63 | (lambda () 64 | (ws:run-server 12345)) 65 | :name "websockets server") 66 | 67 | #++ 68 | (bordeaux-threads:make-thread 69 | (lambda () 70 | (ws:run-resource-listener (ws:find-global-resource "/echo"))) 71 | :name "resource listener for /echo") 72 | 73 | #++ 74 | (kill-resource-listener (ws:find-global-resource "/echo")) 75 | 76 | 77 | ;;; for autobahn test suite 78 | #++ 79 | (register-global-resource 80 | "/" 81 | (make-instance 'echo-resource) 82 | #'ws::any-origin) 83 | 84 | #++ 85 | (bordeaux-threads:make-thread 86 | (lambda () 87 | (ws:run-resource-listener (ws:find-global-resource "/"))) 88 | :name "resource listener for /") 89 | 90 | #++ 91 | (kill-resource-listener (ws:find-global-resource "/")) 92 | 93 | 94 | ;;;; Chat server 95 | ;;;; ----------- 96 | 97 | (defclass chat-server (ws-resource) 98 | ((clients :initform () :accessor clients))) 99 | 100 | 101 | (register-global-resource 102 | "/chat" 103 | (make-instance 'chat-server) 104 | #'ws::any-origin 105 | #++ 106 | (ws::origin-prefix "http://127.0.0.1" "http://localhost")) 107 | 108 | (defmethod resource-client-connected ((res chat-server) client) 109 | (format t "got connection on chat server from ~s : ~s~%" (client-host client) (client-port client)) 110 | (push client (clients res)) 111 | (let ((*print-pretty* nil)) 112 | (write-to-clients-text (clients res) 113 | (format nil "client joined from ~s.~s, ws protocol ~s" 114 | (client-host client) 115 | (client-port client) 116 | (client-websocket-version client))) 117 | (write-to-client-text client 118 | (format nil "headers = ~s~%" 119 | (alexandria:hash-table-alist (client-connection-headers client))))) 120 | t) 121 | 122 | (defmethod resource-client-disconnected ((resource chat-server) client) 123 | (format t "Client disconnected from resource ~A: ~A~%" resource client) 124 | (setf (clients resource) (remove client (clients resource))) 125 | (write-to-clients-text (clients resource) 126 | (format nil "client from ~s.~s left" 127 | (client-host client) 128 | (client-port client)))) 129 | 130 | (defmethod resource-received-text ((res chat-server) client message) 131 | ;(format t "got frame ~s from chat client ~s" message client) 132 | (let ((*print-pretty* nil)) 133 | (write-to-clients-text (clients res) 134 | (format nil "chat: ~s.~s : |~s|" 135 | (client-host client) 136 | (client-port client) 137 | message)))) 138 | 139 | (defmethod resource-received-binary ((res chat-server) client message) 140 | ;(format t "got frame ~s from chat client ~s" message client) 141 | (let ((*print-pretty* nil) 142 | (binary-clients) 143 | (text-clients)) 144 | (loop for c in (clients res) 145 | do (if (> (client-websocket-version c) 0) 146 | (push c binary-clients) 147 | (push c text-clients))) 148 | (write-to-clients-text (clients res) 149 | (format nil "chat: binary message from ~s.~s" 150 | (client-host client) 151 | (client-port client))) 152 | (write-to-clients-binary binary-clients message))) 153 | 154 | #++ 155 | (bordeaux-threads:make-thread 156 | (lambda () 157 | (ws:run-resource-listener (ws:find-global-resource "/chat"))) 158 | :name "chat resource listener for /chat") 159 | -------------------------------------------------------------------------------- /protocol-00.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | ;;; (todo? hixie75, chrome4/safari 5.0.0) 4 | 5 | ;;; draft hixie-76/hybi-00 protocol support 6 | ;;; used by firefox4/5, chrome6-13?, safari 5.0.1, opera 11 7 | ;;; (firefox and opera disabled by default) 8 | (defparameter *draft-76/00-close-frame* 9 | (make-array-ubyte8 2 :initial-contents '(#xff #x00))) 10 | 11 | #++ 12 | (defparameter *allow-draft-75* t) 13 | #++ 14 | (defun make-handshake-75 (origin location protocol) 15 | (string-to-shareable-octets 16 | (format nil "HTTP/1.1 101 Web Socket Protocol Handshake 17 | Upgrade: WebSocket 18 | Connection: Upgrade 19 | WebSocket-Origin: ~a 20 | WebSocket-Location: ~a 21 | WebSocket-Protocol: ~a 22 | 23 | " 24 | origin 25 | location 26 | protocol) 27 | :encoding :utf-8)) 28 | 29 | (defun make-handshake-76 (origin location protocol) 30 | (string-to-shareable-octets 31 | (format nil "HTTP/1.1 101 Web Socket Protocol Handshake 32 | Upgrade: WebSocket 33 | Connection: Upgrade 34 | Sec-WebSocket-Origin: ~a 35 | Sec-WebSocket-Location: ~a 36 | Sec-WebSocket-Protocol: ~a 37 | 38 | " 39 | origin 40 | location 41 | protocol) 42 | :encoding :utf-8)) 43 | #++ 44 | (defun make-handshake (origin location protocol version) 45 | "Returns a WebSockets handshake string returned by a server to a 46 | client." 47 | (ecase version 48 | (:draft-75 (make-handshake-75 origin location protocol)) 49 | (:draft-76 (make-handshake-76 origin location protocol)))) 50 | 51 | 52 | (defun extract-key (k) 53 | (when k 54 | (loop 55 | :with n = 0 56 | :for i across k 57 | :when (char= i #\space) 58 | :count 1 :into spaces 59 | :when (digit-char-p i) 60 | :do (setf n (+ (* n 10) (digit-char-p i))) 61 | :finally (return 62 | (multiple-value-bind (d r) (floor n spaces) 63 | (when (zerop r) 64 | d)))))) 65 | ;; (extract-key "3e6b263 4 17 80") -> 906585445 66 | ;; (extract-key "17 9 G`ZD9 2 2b 7X 3 /r90") -> 179922739 67 | 68 | (defun make-challenge-00 (k1 k2 k3) 69 | (let ((b (make-array-ubyte8 16))) 70 | (loop for i from 0 below 4 71 | for j from 24 downto 0 by 8 72 | do (setf (aref b i) (ldb (byte 8 j) k1)) 73 | do (setf (aref b (+ 4 i)) (ldb (byte 8 j) k2))) 74 | (replace b k3 :start1 8 :end1 16 ) 75 | b)) 76 | 77 | 78 | (defun protocol-76/00-nonce (client) 79 | (next-reader-state 80 | client 81 | (octet-count-matcher 8) 82 | (lambda (client) 83 | (flet ((error-exit (message) 84 | (send-error-and-close client message) 85 | (return-from protocol-76/00-nonce nil))) 86 | (let ((nonce (get-octet-vector (chunks client))) 87 | (headers (client-connection-headers client)) 88 | (resource-name (client-resource-name client))) 89 | (destructuring-bind (resource check-origin) 90 | (valid-resource-p (client-server client) resource-name) 91 | (unless resource 92 | (error-exit *404-message*)) 93 | (unless (funcall check-origin (gethash :origin headers)) 94 | (error-exit *403-message*)) 95 | 96 | (multiple-value-bind (acceptp rqueue origin handshake-resource protocol) 97 | (resource-accept-connection resource resource-name 98 | headers 99 | client) 100 | (declare (ignorable origin handshake-resource protocol)) 101 | (when (not acceptp) 102 | (error-exit *403-message*)) 103 | (setf (client-read-queue client) (or rqueue 104 | (resource-read-queue resource) 105 | (make-mailbox)) 106 | (client-resource client) resource 107 | (client-websocket-version client) 0) 108 | (client-enqueue-write 109 | client 110 | (make-handshake-76 (or origin 111 | (gethash :origin headers) 112 | "http://127.0.0.1/") 113 | (let ((*print-pretty*)) 114 | (format nil "~a~a~a" 115 | "ws://" 116 | (or (gethash :host headers) 117 | "127.0.0.1:12345") 118 | (or handshake-resource 119 | resource-name))) 120 | (or protocol 121 | (gethash :websocket-protocol headers) 122 | "test"))) 123 | (client-enqueue-write 124 | client 125 | (ironclad:digest-sequence 126 | 'ironclad:md5 127 | (make-challenge-00 128 | (extract-key (gethash :sec-websocket-key1 headers)) 129 | (extract-key (gethash :sec-websocket-key2 headers)) 130 | nonce))) 131 | (setf (client-connection-state client) :connected) 132 | (client-enqueue-read client (list client :connect))) 133 | (protocol-76/00-frame-start client))))))) 134 | 135 | (defun protocol-76/00-read-text-frame (client) 136 | (next-reader-state 137 | client 138 | (octet-pattern-matcher #(#xff) *max-read-message-size*) 139 | (lambda (client) 140 | (let ((s (get-utf8-string-or-fail (chunks client) :skip-octets-end 1))) 141 | (client-enqueue-read client (list client (list :text s))) 142 | (protocol-76/00-frame-start client))))) 143 | 144 | (defun protocol-76/00-read-binary-frame (client) 145 | (next-reader-state 146 | client 147 | (octet-count-matcher 1) 148 | (lambda (client) 149 | (let ((o (read-octet (chunks client)))) 150 | ;; only allowed binary frame is 0-length close frame 151 | (if (zerop o) 152 | (error 'close-from-peer :status-code 1005) 153 | (error 'fail-the-websockets-connection)))))) 154 | 155 | (defun protocol-76/00-frame-start (client) 156 | (next-reader-state 157 | client 158 | (octet-count-matcher 1) 159 | (lambda (client) 160 | (let ((frame-type (read-octet (chunks client)))) 161 | (cond 162 | ((eql frame-type #x00) 163 | (setf (message-opcode client) frame-type)0 164 | (protocol-76/00-read-text-frame client)) 165 | ((eql frame-type #xff) 166 | (setf (message-opcode client) frame-type) 167 | (protocol-76/00-read-binary-frame client)) 168 | (t 169 | ;; unused message, just for debugging 170 | (error 'fail-the-websockets-connection 171 | :message (format nil "unknown frame type #x~2,'0x" frame-type)))))))) 172 | -------------------------------------------------------------------------------- /server.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | (defparameter *server-busy-message* 4 | (string-to-shareable-octets 5 | (format nil "HTTP/1.1 503 service unavailable~A~A" +crlf+ +crlf+) 6 | :encoding :utf-8)) 7 | 8 | (defclass server () 9 | ((event-base :initform nil :accessor server-event-base :initarg :event-base) 10 | (clients :initform (make-hash-table) :reader server-clients 11 | :documentation "Hash of client objects to them 12 | selves (just used as a set for now).")) 13 | (:documentation "A WebSockets server listens on a socket for 14 | connections and has a bunch of client instances that it controls.")) 15 | 16 | (defgeneric server-client-count (server) 17 | (:documentation "Returns number the server's clients.")) 18 | 19 | (defgeneric server-list-clients (server) 20 | (:documentation "Returns a list of the server's clients.")) 21 | 22 | (defmethod server-list-clients ((server server)) 23 | (loop :for v :being the hash-values :of (server-clients server) 24 | :collect v)) 25 | 26 | (defmethod server-client-count ((server server)) 27 | (hash-table-count (server-clients server))) 28 | 29 | (defun make-listener-handler (server socket server-hook) 30 | (lambda (fd event exception) 31 | (declare (ignore fd event exception)) 32 | (let* ((client-socket (accept-connection socket :wait t)) 33 | (client (when client-socket 34 | (make-instance 'client 35 | :server server 36 | :%host (remote-host client-socket) 37 | :host (address-to-string 38 | (remote-host client-socket)) 39 | :port (remote-port client-socket) 40 | :server-hook server-hook 41 | :socket client-socket)))) 42 | (when client 43 | (lg "got client connection from ~s ~s~%" (client-host client) 44 | (client-port client)) 45 | (lg "client count = ~s/~s~%" (server-client-count server) *max-clients*) 46 | ;; fixme: probably shouldn't do this if we are dropping the connection 47 | ;; due to too many connections? 48 | (setf (gethash client (server-clients server)) client) 49 | (cond 50 | ((and *max-clients* (> (server-client-count server) *max-clients*)) 51 | ;; too many clients, send a server busy response and close connection 52 | (client-disconnect client :read t) 53 | (client-enqueue-write client *server-busy-message*) 54 | (client-enqueue-write client :close)) 55 | (t 56 | ;; otherwise handle normally 57 | (add-reader-to-client client))))))) 58 | 59 | (defun run-server (port &key (addr +ipv4-unspecified+)) 60 | "Starts a server on the given PORT and blocks until the server is 61 | closed. Intended to run in a dedicated thread (the current one), 62 | dubbed the Server Thread. 63 | 64 | Establishes a socket listener in the current thread. This thread 65 | handles all incoming connections, and because of this fact is able to 66 | handle far more concurrent connections than it would be able to if it 67 | spawned off a new thread for each connection. As such, most of the 68 | processing is done on the Server Thread, though most user functions 69 | are thread-safe. 70 | 71 | " 72 | (let* ((event-base (make-instance 'iolib:event-base)) 73 | (server (make-instance 'server 74 | :event-base event-base)) 75 | (temp (make-array-ubyte8 16)) 76 | (control-mailbox (make-queue :name "server-control")) 77 | (wake-up (make-array-ubyte8 1 :initial-element 0))) 78 | ;; To be clear, there are three sockets used for a server. The 79 | ;; main one is the WebSockets server (socket). There is also a 80 | ;; pair of connected sockets (control-socket-1 control-socket-2) 81 | ;; used merely as a means of making the server thread execute a 82 | ;; lambda from a different thread. 83 | (multiple-value-bind (control-socket-1 control-socket-2) 84 | (make-socket-pair) 85 | (flet ((execute-in-server-thread (thunk) 86 | ;; hook for waking up the server and telling it to run 87 | ;; some code, for things like enabling writers when 88 | ;; there is new data to write 89 | (enqueue thunk control-mailbox) 90 | (if *debug-on-server-errors* 91 | (iolib:send-to control-socket-2 wake-up) 92 | (ignore-errors 93 | (iolib:send-to control-socket-2 wake-up))))) 94 | (unwind-protect 95 | (iolib:with-open-socket (socket :connect :passive 96 | :address-family :internet 97 | :type :stream 98 | :ipv6 nil 99 | ;;:external-format '(unsigned-byte 8) 100 | ;; bind and listen as well 101 | :local-host addr 102 | :local-port port 103 | :backlog 5 104 | :reuse-address t 105 | #++ :no-delay) 106 | (iolib:set-io-handler event-base 107 | (socket-os-fd control-socket-1) 108 | :read (lambda (fd e ex) 109 | (declare (ignorable fd e ex)) 110 | (receive-from control-socket-1 111 | :buffer temp 112 | :start 0 :end 16) 113 | (loop for m = (dequeue control-mailbox) 114 | while m 115 | do (funcall m)))) 116 | (iolib:set-io-handler event-base 117 | (iolib:socket-os-fd socket) 118 | :read (let ((true-handler (make-listener-handler 119 | server 120 | socket 121 | #'execute-in-server-thread))) 122 | (lambda (&rest rest) 123 | (lg "There is something to read on fd ~A~%" (first rest)) 124 | (apply true-handler rest)))) 125 | (handler-case 126 | (event-dispatch event-base) 127 | ;; ... handle errors 128 | ) 129 | ) 130 | (loop :for v :in (server-list-clients server) 131 | :do 132 | (lg "cleanup up dropping client ~s~%" v) 133 | (client-enqueue-read v (list v :dropped)) 134 | (client-disconnect v :abort t)) 135 | (close control-socket-1) 136 | (close control-socket-2)))))) 137 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CLWS - a [WebSocket][] server in Common Lisp 2 | 3 | Currently requires SBCL or CCL, but shouldn't be too hard to port to 4 | other implementations/platforms supported by iolib. 5 | 6 | Supports [WebSocket][] draft protocols [7][],[8][], and [13][], and optionally 7 | [0][]. 8 | 9 | Doesn't currently support `wss:` (TLS/SSL) connections, but proxying behind [stud][] or [stunnel][] should work. 10 | 11 | [WebSocket]: http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-15 12 | [hixie]: http://tools.ietf.org/html/draft-hixie-thewebsocketprotocol 13 | [0]: http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-00 14 | [7]: http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07 15 | [8]: http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-08 16 | [13]: http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-15 17 | [stud]: https://github.com/bumptech/stud 18 | [stunnel]: http:www.stunnel.org/ 19 | 20 | 21 | 22 | ## Sample usage: Echo Server 23 | 24 | First, set up a package: 25 | 26 | ```lisp 27 | (defpackage #:clws-echo 28 | (:use :cl :clws)) 29 | 30 | (in-package #:clws-echo) 31 | 32 | ``` 33 | 34 | Then we can start the websockets server, here we use port 12345: 35 | 36 | ```lisp 37 | (bordeaux-threads:make-thread (lambda () 38 | (run-server 12345)) 39 | :name "websockets server") 40 | ``` 41 | 42 | Next we need to define a 'resource', which we will call `/echo` (so we will connect with URIs like `ws://localhost/echo`). To do that, we subclass `ws-resource` and specialize a few generic functions on that class: 43 | 44 | ```lisp 45 | (defclass echo-resource (ws-resource) 46 | ()) 47 | 48 | (defmethod resource-client-connected ((res echo-resource) client) 49 | (format t "got connection on echo server from ~s : ~s~%" (client-host client) (client-port client)) 50 | t) 51 | 52 | (defmethod resource-client-disconnected ((resource echo-resource) client) 53 | (format t "Client disconnected from resource ~A: ~A~%" resource client)) 54 | 55 | (defmethod resource-received-text ((res echo-resource) client message) 56 | (format t "got frame ~s from client ~s" message client) 57 | (write-to-client-text client message)) 58 | 59 | (defmethod resource-received-binary((res echo-resource) client message) 60 | (format t "got binary frame ~s from client ~s" (length message) client) 61 | (write-to-client-binary client message)) 62 | ``` 63 | 64 | Finally, we register the resource with the server, and start a thread to handle messages for that resource: 65 | 66 | ```lisp 67 | (register-global-resource "/echo" 68 | (make-instance 'echo-resource) 69 | (origin-prefix "http://127.0.0.1" "http://localhost")) 70 | 71 | (bordeaux-threads:make-thread (lambda () 72 | (run-resource-listener 73 | (find-global-resource "/echo"))) 74 | :name "resource listener for /echo") 75 | ``` 76 | 77 | 78 | ## Configuration variables 79 | 80 | * `*protocol-76/00-support*`: set to T to enable support for [draft-hixie-76][hixie]/[draft-ietf-hybi-00][0] protocol 81 | No longer used by current browsers, and doesn't support binary frames. May go away soon. 82 | 83 | * `*default-socket-backlog*`: default socket backlog parameter for the server listener (default: 5). 84 | Controls how many pending connections can be queued before the OS starts rejecting them. Can be overridden with the `:backlog` keyword argument to `run-server`. 85 | 86 | * `*max-clients*`: maximum number of simultaneous connections allowed, or `NIL` for no limit 87 | 88 | * `*max-read-frame-size*`, `*max-read-message-size*`: maximum 'frame' and 'message' sizes allowed from clients. 89 | Malicious clients can cause the server to buffer up to `*max-read-message-size*` per connection, so these should probably be reduced as much as possible for production servers. 90 | 91 | * `*debug-on-server-errors*`, `*debug-on-resource-errors*`: set to T to enter debugger on errors instead of dropping connections, for the server thread and resource handler thread respectively. 92 | 93 | ## Resource handler API 94 | 95 | * `register-global-resource (name resource-handler origin-validation-function)`: 96 | Registers `resource-handler` for the resource `name`, which should be the `abs_path` part of a URI, like `/foo/bar`, `origin-validation-function` should be a function of one argument which returns true for any origin from which connections will be accepted. See `any-origin`,`origin-prefix`,`origin-exact`. ("Origin" in this case refers to the value of the `Origin` or `Sec-Webcosket-Origin` header required to be sent by browsers, specifying the host from which the page was loaded, like `http://localhost`.) 97 | 98 | * `resource-received-text (resource client message)`: Resource handlers should specialize this generic function to handle `text` messages from clients. `message` is a lisp `string` containing the message from `client`. 99 | 100 | * `resource-received-binary (resource client message)`: Resource handlers should specialize this generic function to handle `binary` messages from clients. `message` is a `(vector (unsigned-byte 8))` containing the message from `client`. 101 | 102 | * `resource-received-pong (resource client message)`: Resource handlers can specialize this generic function to handle `pong` frames from clients. `message` is the payload data from the pong frame (may be empty). This is typically used for latency testing and connection keep-alive monitoring when combined with `write-to-client-ping`. 103 | 104 | * `resource-client-connected (resource client)`: Called to notify a resource handler when a client connects. If the handler objects to a particular client for some reason, it can return `:reject` to close the connection and ignore any already received data from that client. 105 | 106 | * `resource-client-disconnected (resource client)`: Called when a client disconnects. 107 | 108 | ## Sending data to clients 109 | 110 | * `write-to-client-text (client message &key frame-size)`: Send `message` to `client`. `message` should be a CL `string` or a `(simple-array (unsigned-byte 8) (*))` containing a utf-8 encoded string. If `frame-size` is not `nil`, message will be broken up into frames of `frame-size` octets. 111 | 112 | * `write-to-clients-text (clients message &key frame-size)`: Send `message` to a list of `clients`. Same as `write-to-client-text`, but tries to avoid repeated processing (utf-8 encoding, building frames, etc) that can be shared between clients. 113 | 114 | * `write-to-client-binary (client message &key frame-size)`: Send `message` to `client`. `message` should be a `(simple-array (unsigned-byte 8) (*))`. If `frame-size` is not `nil`, message will be broken up into frames of `frame-size` octets. 115 | 116 | * `write-to-clients-binary (clients message &key frame-size)`: Send `message` to a list of `clients`. Same as `write-to-client-binary`, but tries to avoid repeated processing (utf-8 encoding, building frames, etc) that can be shared between clients. 117 | 118 | * `write-to-client-close (client &key (code 1000) message)`: Send a `close` message to `client`. `code` specifies the 'status code' to be send in the close message (see the [websocket spec][http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-15#section-7.4] for valid codes) defaults to 1000, indicating "normal closure". `message` can be a short string (must utf-8 encode to < 123 octets) describing the reason for closing the connection. 119 | 120 | * `write-to-client-ping (client &optional message)`: Send a `ping` frame to `client` according to RFC 6455. `message` is optional payload data (max 125 bytes). The client must respond with a pong frame containing the same payload data. Useful for connection keep-alive and latency testing. 121 | 122 | ## Getting information about connected clients 123 | (most of these should be treated as read-only, and any visible `setf` 124 | functions may go away at some point) 125 | 126 | * `client-resource-name (client)`: Name of resource requested by `client`. 127 | 128 | * `client-query-string (client)`: Query string (the part of the URI after #\? if any) provided by `client` when connecting. 129 | For example if client connects to `ws://example.com/test?foo`, `client-resource-name` would return `"/test"` and `client-query-string` would return `"foo"`. 130 | 131 | * `client-websocket-version (client)`: Protocol version being used for specified `client`. 132 | 133 | * `client-host (client)`: IP address of client, as a string. 134 | 135 | * `client-port (client)`: Port from which client connected. 136 | 137 | * `client-connection-headers (client)`: Hash table containing any HTTP headers supplied by `client`, as a hash table of keywords (`:user-agent`, `:cookie`, etc) -> strings. 138 | 139 | 140 | 141 | 142 | -------------------------------------------------------------------------------- /test.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ws-test 2 | (:use #:cl #:iolib)) 3 | (in-package #:ws-test) 4 | 5 | (defparameter *ws-host* "127.0.0.1") 6 | (defparameter *ws-port* 12345) 7 | (defparameter *ws-base-path* "") 8 | 9 | (defun ws-url (resource) 10 | (format nil "ws://~a:~a~a~a" *ws-host* *ws-port* *ws-base-path* resource)) 11 | 12 | (defun handshake (resource) 13 | (let ((crlf (format nil "~c~c" (code-char 13) (code-char 10)))) 14 | (string-to-shareable-octets 15 | (print (format nil "GET ~a HTTP/1.1~a~ 16 | Upgrade: WebSocket~a~ 17 | Connection: Upgrade~a~ 18 | Host: ~a:~a~a~ 19 | Origin: http://~a~a~ 20 | WebSocket-Protocol: ~a~a~ 21 | ~a" 22 | resource crlf 23 | crlf 24 | crlf 25 | *ws-host* *ws-port* crlf 26 | *ws-host* crlf 27 | "test" crlf 28 | crlf))))) 29 | 30 | (defun handshake-76 (resource) 31 | (let ((crlf (format nil "~c~c" (code-char 13) (code-char 10)))) 32 | (string-to-shareable-octets 33 | (print (format nil "GET ~a HTTP/1.1~a~ 34 | Upgrade: WebSocket~a~ 35 | Connection: Upgrade~a~ 36 | Host: ~a:~a~a~ 37 | Origin: http://~a~a~ 38 | WebSocket-Protocol: ~a~a~ 39 | Sec-WebSocket-Key1: 3e6b263 4 17 80~a~ 40 | Sec-WebSocket-Key2: 17 9 G`ZD9 2 2b 7X 3 /r90~a~ 41 | ~a~ 42 | WjN}|M(6" 43 | resource crlf 44 | crlf 45 | crlf 46 | *ws-host* *ws-port* crlf 47 | *ws-host* crlf 48 | "test" crlf 49 | crlf 50 | crlf 51 | crlf))))) 52 | 53 | (defun x (socket &key abort) 54 | (ignore-errors (shutdown socket :read t :write t)) 55 | (close socket :abort abort)) 56 | 57 | ;(babel:octets-to-string (handshake "/chat")) 58 | ;(length (handshake "/chat")) 59 | 60 | ;; fixme: organize this stuff and use some real testing lib 61 | 62 | (defun ws-connect () 63 | (make-socket :connect :active :address-family :internet 64 | :type :stream 65 | :remote-host *ws-host* :remote-port *ws-port* 66 | )) 67 | 68 | ;(close (ws-connect)) 69 | ;(close (ws-connect) :abort t) 70 | (defun send-handshake (socket resource) 71 | (let ((handshake (handshake resource))) 72 | (send-to socket handshake)) 73 | socket) 74 | 75 | (defun send-handshake-76 (socket resource) 76 | (let ((handshake (handshake-76 resource))) 77 | (send-to socket handshake)) 78 | socket) 79 | 80 | (defun send-handshake-fragmented (socket resource fragsize) 81 | (let ((handshake (handshake resource))) 82 | (loop for i from 0 below (length handshake) by fragsize 83 | do (send-to socket handshake :start i :end (+ i (min fragsize 84 | (- (length handshake) 85 | i)))) 86 | (force-output socket) 87 | (sleep 0.01))) 88 | socket) 89 | 90 | (defun send-handshake-incomplete (socket resource fragsize) 91 | (let ((handshake (handshake resource))) 92 | (send-to socket handshake :start 0 :end (min fragsize 93 | (length handshake))) 94 | (force-output socket)) 95 | socket) 96 | 97 | (defun read-handshake (socket) 98 | (loop repeat 100 99 | for (i l) = (multiple-value-list 100 | (handler-case 101 | (receive-from socket :size 2048 :dont-wait t) 102 | (isys:ewouldblock () 103 | nil))) 104 | do (sleep 0.01) 105 | (when i 106 | (format t "read |~s|~%" (babel:octets-to-string i :encoding :utf-8 :end l :errorp nil)) 107 | (format t "read (~{0x~2,'0x ~})~%" (coerce (subseq i (max 0 (- l 16)) l) 'list)))) 108 | socket) 109 | (defun read-handshake-rl (socket) 110 | (loop repeat 7 111 | do (format t "handshake: ~s~%" (read-line socket))) 112 | socket) 113 | #++ 114 | (x (send-handshake (ws-connect) "/chat")) 115 | #++ 116 | (x (read-handshake (send-handshake-76 (ws-connect) "/chat"))) 117 | #++ 118 | (x (send-handshake-fragmented (ws-connect) "/chat" 2)) 119 | #++ 120 | (x (read-handshake-rl (send-handshake (ws-connect) "/echo"))) 121 | #++ 122 | (loop for i from 1 below (length (handshake "/chat")) 123 | do (format t "-----------~% --> ~s~%" i) 124 | (x (read-handshake-rl (send-handshake-fragmented (ws-connect) "/chat" i)))) 125 | #++ 126 | (x (send-handshake-incomplete (ws-connect) "/chat" 2)) 127 | #++ 128 | (loop for i from 1 below (1+ (length (handshake "/chat"))) 129 | do (format t "-----------~% --> ~s~%" i) 130 | (x (send-handshake-incomplete (ws-connect) "/chat" i)) 131 | (sleep 0.01)) 132 | 133 | #++ 134 | (loop for i from 1 below (1+ (length (handshake "/chat"))) 135 | do (format t "-----------~% --> ~s~%" i) 136 | (x (send-handshake-incomplete (ws-connect) "/chat" i) :abort t) 137 | (sleep 0.01)) 138 | 139 | 140 | #++ 141 | (let ((*ws-host* "3bb.cc")) 142 | (loop with s = (send-handshake (ws-connect) "/chat") 143 | for i from 1 144 | repeat 1000 145 | do (write-byte 0 s) 146 | (format s "test ~s ddddddd dddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddq" i) 147 | ;(format t "test ~s" i) 148 | (write-byte #xff s) 149 | (finish-output s) 150 | (sleep 0.01) 151 | finally (x s))) 152 | 153 | 154 | #++ 155 | (loop with s = (send-handshake (ws-connect) "/echo") 156 | for i from 1 157 | repeat 1000 158 | do (write-byte 0 s) 159 | (format s "test ~s ddddddd dddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddd dddddddddddddddddddq" i) 160 | ;(format t "test ~s" i) 161 | (write-byte #xff s) 162 | (finish-output s) 163 | (loop repeat 100 164 | while (ignore-errors (receive-from s :size 1024))) 165 | (sleep 0.01) 166 | finally (x s)) 167 | 168 | 169 | #++ 170 | (macrolet ((ignore-some-errors (&body body) 171 | `(handler-case 172 | (progn ,@body) 173 | (iolib.sockets:socket-not-connected-error () 174 | (format t "enotconn ~s~%" ,(format nil "~s" body)) 175 | nil) 176 | (isys:epipe () 177 | (format t "epipe in disconnect~%") 178 | nil) 179 | (isys:enotconn () 180 | (format t "enotconn in shutdown/close?") 181 | nil)))) 182 | (loop 183 | for i1 below 50 184 | do 185 | (sleep 0.05) 186 | (sb-thread:make-thread 187 | (lambda () 188 | (let (#++(*ws-host* "3bb.cc") 189 | #++(*ws-port* 12346) 190 | (i1 i1)) 191 | (format t " thread ~s read ~s~%" 192 | i1 193 | (loop with s = (prog1 194 | (send-handshake (ws-connect) "/chat") 195 | (sleep 5)) 196 | for i from 1 197 | repeat 5000 198 | do (write-byte 0 s) 199 | (format s "test ~s " i) 200 | ;(format t "test ~s" i) 201 | (write-byte #xff s) 202 | (finish-output s) 203 | sum 204 | (loop repeat 100 205 | for x = (ignore-errors (receive-from s :size 1024)) 206 | while x 207 | sum (count #xff x)) 208 | into c 209 | do (sleep 0.005) 210 | finally 211 | (progn 212 | (format t "thread ~s waiting~%" i1) 213 | (sleep 1) 214 | (ignore-some-errors (shutdown s :write t)) 215 | (return 216 | (let ((c2 #++(loop while (socket-connected-p s) 217 | repeat 600 218 | do (sleep 0.1) 219 | sum (loop for x = (ignore-errors (receive-from s :size 1024)) 220 | while x 221 | sum (count #xff x))) 222 | (loop for x = (Read-byte s nil nil) 223 | while x 224 | count (= x #xff)))) 225 | (x s) 226 | (list c c2 (+ c c2))))))))) 227 | :name (format nil "thread ~s" i1)))) 228 | 229 | 230 | 231 | -------------------------------------------------------------------------------- /resource.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | ;;; resource stuff 4 | ;;; 5 | ;;; name ("/foo", etc) 6 | ;;; 7 | ;;; accept function 8 | ;;; args = resource name, headers, client host/port 9 | ;;; return 10 | ;;; reject connection 11 | ;;; abort connection? 12 | ;;; ? for accepted 13 | 14 | ;; fixme: make this per-server, so we can run different servers on 15 | ;; different ports? 16 | ;; fixme: add support for more complex matching than just exact match 17 | (defparameter *resources* (make-hash-table :test 'equal) 18 | "hash mapping resource name to (list of handler instance, origin 19 | validation function, ?)") 20 | 21 | (defun register-global-resource (name resource-handler origin-validation-fn) 22 | "Registers a resource instance where NAME is a path string like 23 | '/swank', resource-handler is an instance of WS-RESOURCE, and 24 | ORIGIN-VALIDATION-FN is a function that takes an origin string as 25 | input and returns T if that origin is allowed to access this 26 | resource." 27 | (setf (gethash name *resources*) 28 | (list resource-handler origin-validation-fn))) 29 | 30 | (defun find-global-resource (name) 31 | "Returns the resource registered via REGISTER-GLOBAL-RESOURCE with name NAME." 32 | (first (gethash name *resources*))) 33 | 34 | (defun unregister-global-resource (name) 35 | "Removes the resource registered via REGISTER-GLOBAL-RESOURCE with name NAME." 36 | (remhash name *resources*)) 37 | 38 | (defun valid-resource-p (server resource) 39 | "Returns non-nil if there is a handler registered for the resource 40 | of the given name (a string)." 41 | (declare (type string resource) 42 | (ignore server)) 43 | (when resource 44 | (gethash resource *resources*))) 45 | 46 | ;; functions for checking origins... 47 | (defun any-origin (o) (declare (ignore o)) t) 48 | 49 | (defun origin-prefix (&rest prefixes) 50 | "Returns a function that checks whether a given path matches any of 51 | the prefixes passed as arguments." 52 | (lambda (o) 53 | (loop :for p :in prefixes 54 | :for m = (mismatch o p) 55 | :when (or (not m) (= m (length p))) 56 | :return t))) 57 | 58 | (defun origin-exact (&rest origins) 59 | "Returns a function that checks whether a given path matches any of 60 | the origins passed as arguments exactly." 61 | ;; fixme: probably should use something better than a linear search 62 | (lambda (o) 63 | (member o origins :test #'string=))) 64 | 65 | (defgeneric resource-read-queue (resource) 66 | (:documentation "The concurrent mailbox used to pass messages 67 | between the server thread and resource thread.")) 68 | 69 | (defclass ws-resource () 70 | ((read-queue :initform (make-mailbox) :reader resource-read-queue)) 71 | (:documentation "A server may have many resources, each associated 72 | with a particular resource path (like /echo or /chat). An single 73 | instance of a resource handles all requests on the server for that 74 | particular url, with the help of RUN-RESOURCE-LISTENER, 75 | RESOURCE-RECEIVED-FRAME, and RESOURCE-CLIENT-DISCONNECTED.")) 76 | 77 | (defgeneric resource-accept-connection (res resource-name headers client) 78 | (:documentation "Decides whether to accept a connection and returns 79 | values to process the connection further. Defaults to accepting all 80 | connections and using the default mailbox and origin, so most resources 81 | shouldn't need to define a method. 82 | 83 | Passed values 84 | - RES is the instance of ws-resource 85 | - RESOURCE-NAME is the resource name requested by the client (string) 86 | - HEADERS is the hash table of headers from the client 87 | - client is the instance of client 88 | 89 | Returns values 90 | 1. NIL if the connection should be rejected, or non-nil otherwise 91 | 2. Concurrent mailbox in which to place messages received from the 92 | client, or NIL for default 93 | 3. origin from which to claim this resource is responding, or NIL 94 | for default. 95 | 4. handshake-resource or NIL for default 96 | 5. protocol or NIL for default 97 | 98 | Most of the time this function will just return true for the first 99 | value to accept the connection, and nil for the other values. 100 | 101 | Note that the connection is not fully established yet, so this 102 | function should not try to send anything to the client, see 103 | resource-client-connected for that. 104 | 105 | This function may be called from a different thread than most resource 106 | functions, so methods should be careful about accessing shared data, and 107 | should avoid blocking for extended periods. 108 | ")) 109 | 110 | (defgeneric resource-client-disconnected (resource client) 111 | (:documentation "Called when a client disconnected from a WebSockets resource.")) 112 | 113 | (defgeneric resource-client-connected (resource client) 114 | (:documentation "Called when a client finishes connecting to a 115 | WebSockets resource, and data can be sent to the client. 116 | 117 | Methods can return :reject to immediately close the connection and 118 | ignore any already received data from this client.")) 119 | 120 | #++ 121 | (defgeneric resource-received-frame (resource client message) 122 | ;;; not used for the moment, since newer ws spec combine 'frame's into 123 | ;;; 'message's, which might be binary or text... 124 | ;;; may add this back later as an interface to processing per frame 125 | ;;; instead of per message? 126 | (:documentation "Called when a client sent a frame to a WebSockets resource.")) 127 | (defgeneric resource-received-text (resource client message) 128 | (:documentation "Called when a client sent a text message to a WebSockets resource.")) 129 | 130 | (defgeneric resource-received-binary (resource client message) 131 | (:documentation "Called when a client sent a binary message to a WebSockets resource.")) 132 | 133 | (defgeneric resource-received-pong (resource client message) 134 | (:documentation "Called when a client sent a pong frame to a WebSockets resource. 135 | MESSAGE is the payload data from the pong frame (may be empty). 136 | This is typically used for latency testing and connection keep-alive monitoring.")) 137 | 138 | (defgeneric resource-received-custom-message (resource message) 139 | (:documentation "Called on the resource listener thread when a 140 | client is passed an arbitrary message via 141 | SEND-CUSTOM-MESSAGE-TO-RESOURCE. ")) 142 | 143 | (defgeneric send-custom-message-to-resource (resource message) 144 | (:documentation "Thread-safe way to pass a message to the resource 145 | listener. Any message passed with this function will result in 146 | RESOURCE-RECEIVED-CUSTOM-MESSAGE being called on the resource thread 147 | with the second argument of this function.")) 148 | 149 | (defmethod resource-accept-connection (res resource-name headers client) 150 | (declare (ignore res resource-name headers client)) 151 | t) 152 | 153 | (defmethod resource-client-connected (res client) 154 | (declare (ignore res client)) 155 | nil) 156 | 157 | (defmethod resource-received-pong (res client message) 158 | (declare (ignore res client message)) 159 | nil) 160 | 161 | (defmethod send-custom-message-to-resource (resource message) 162 | (mailbox-send-message (resource-read-queue resource) 163 | (list message :custom))) 164 | 165 | (defclass funcall-custom-message () 166 | ((function :initarg :function :initform nil :reader message-function)) 167 | (:documentation "A type of so-called 'custom message' used to call a 168 | function on the main resource thread.")) 169 | 170 | (defmethod resource-received-custom-message (resource (message funcall-custom-message)) 171 | (declare (ignore resource)) 172 | (funcall (message-function message))) 173 | 174 | (defgeneric call-on-resource-thread (resource fn) 175 | (:documentation "Funcalls FN on the resource thread of RESOURCE.")) 176 | 177 | (defmethod call-on-resource-thread (resource fn) 178 | (send-custom-message-to-resource 179 | resource (make-instance 'funcall-custom-message :function fn))) 180 | 181 | (defun disconnect-client (client) 182 | (when (client-resource client) 183 | (resource-client-disconnected (client-resource client) client) 184 | (setf (client-resource client) nil))) 185 | 186 | (defun run-resource-listener (resource) 187 | "Runs a resource listener in its own thread indefinitely, calling 188 | RESOURCE-CLIENT-DISCONNECTED and RESOURCE-RECEIVED-FRAME as appropriate." 189 | (macrolet 190 | ((restarts (&body body) 191 | `(handler-bind 192 | ((error 193 | (lambda (c) 194 | (cond 195 | (*debug-on-resource-errors* 196 | (invoke-debugger c)) 197 | (t 198 | (lg "resource handler error ~s, dropping client~%" c) 199 | (invoke-restart 'drop-client)))))) 200 | (restart-case 201 | (progn ,@body) 202 | (drop-client () 203 | (unless (client-connection-rejected client) 204 | (ignore-errors (disconnect-client client))) 205 | ;; none of the defined status codes in draft 14 seem right for 206 | ;; 'server error' 207 | (ignore-errors (write-to-client-close client :code nil)) 208 | (setf (client-connection-rejected client) t)) 209 | (drop-message () #|| do nothing ||#))))) 210 | (loop :for (client data) = (mailbox-receive-message (slot-value resource 'read-queue)) 211 | ;; fixme should probably call some generic function with all 212 | ;; the remaining messages 213 | :while (not (eql data :close-resource)) 214 | :do 215 | (cond 216 | ((eql data :custom) 217 | ;; here we use the client place to store the custom message 218 | (handler-bind 219 | ((error 220 | (lambda (c) 221 | (cond 222 | (*debug-on-resource-errors* 223 | (invoke-debugger c)) 224 | (t 225 | (lg "resource handler error ~s in custom, ignoring~%" c) 226 | (invoke-restart 'continue)))))) 227 | (let ((message client)) 228 | (restart-case 229 | (resource-received-custom-message resource message) 230 | (continue () :report "Continue" ))))) 231 | ((and client (client-connection-rejected client)) 232 | #|| ignore any further queued data from this client ||#) 233 | ((eql data :connect) 234 | (restarts 235 | (when (eq :reject (resource-client-connected resource client)) 236 | (setf (client-connection-rejected client) t) 237 | (write-to-client-close client)))) 238 | ((eql data :eof) 239 | (restarts 240 | (disconnect-client client)) 241 | (write-to-client-close client)) 242 | ((eql data :dropped) 243 | (restarts 244 | (disconnect-client client)) 245 | (write-to-client-close client)) 246 | ((eql data :close-resource) 247 | (restarts 248 | (disconnect-client client))) 249 | ((eql data :flow-control) 250 | (%write-to-client client :enable-read)) 251 | ((symbolp data) 252 | (error "Unknown symbol in read-queue of resource: ~S " data)) 253 | ((consp data) 254 | (restarts 255 | (cond 256 | ((eq (car data) :text) 257 | (resource-received-text resource client (cadr data))) 258 | ((eq (car data) :binary) 259 | (resource-received-binary resource client (cadr data))) 260 | ((eq (car data) :pong) 261 | (resource-received-pong resource client (cadr data))) 262 | (t 263 | (error "Unknown message type: ~S" (car data)))))) 264 | (t 265 | (error "got unknown data in run-resource-listener?")))))) 266 | 267 | (defun kill-resource-listener (resource) 268 | "Terminates a RUN-RESOURCE-LISTENER from another thread." 269 | (mailbox-send-message (resource-read-queue resource) 270 | '(nil :close-resource))) 271 | -------------------------------------------------------------------------------- /protocol-7.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | ;; draft 7/protocol 7 support, used by firefox 6 4 | ;; (also 8 (used by chrome 14/15, ff7) and 13, since they are pretty 5 | ;; much identical) 6 | 7 | (defun make-challenge-o7 (k &aux (o7-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")) 8 | "Compute the WebSocket opening handshake challenge, according to: 9 | 10 | http://tools.ietf.org/html/draft-ietf-hybi-thewebsocketprotocol-07#section-1.3 11 | 12 | Test this with the example provided in the above document: 13 | 14 | (string= (clws::make-challenge-o7 \"dGhlIHNhbXBsZSBub25jZQ==\") 15 | \"s3pPLMBiTxaQ9kYGzzhZRbK+xOo=\") 16 | 17 | ..which must return T." 18 | (cl-base64:usb8-array-to-base64-string 19 | (ironclad:digest-sequence 20 | :sha1 (map '(vector (unsigned-byte 8)) #'char-code 21 | (concatenate 'string k o7-guid))))) 22 | 23 | 24 | (defun protocol-7+-handshake (client version-string origin-key) 25 | ;; required headers: Host, Sec-WebSocket-Key, Sec-WebSocket-Version 26 | ;; optional: Sec-Websocket-Origin, Sec-Websocket-Protocol, Sec-Websocket-Extensions 27 | (flet ((error-exit (message) 28 | (send-error-and-close client message) 29 | (return-from protocol-7+-handshake nil))) 30 | (let* ((headers (client-connection-headers client)) 31 | (host (gethash :host headers nil)) 32 | (key (gethash :sec-websocket-key headers nil)) 33 | (version (gethash :sec-websocket-version headers nil)) 34 | (origin (gethash origin-key headers nil)) 35 | #++(protocol (gethash :sec-websocket-protocol headers nil)) 36 | #++(extensions (gethash :sec-websocket-extensions headers nil)) 37 | (upgrade (gethash :upgrade headers "")) 38 | (connection (mapcar (lambda (a) (string-trim " " a)) 39 | (split-sequence:split-sequence 40 | #\, (gethash :connection headers "")))) 41 | (resource-name (client-resource-name client))) 42 | ;; version 7 requires Host, Sec-Websocket-Key which base64 decodes 43 | ;; to 16 octets, and Sec-Websocket-Version = 7 44 | ;; also need Connection: Upgrade and Upgrade: WebSocket 45 | ;; (ff sends Connection: keep-alive, Upgrade, so split on , first) 46 | (unless (and host key version (and (string= version version-string)) 47 | (string-equal upgrade "websocket") 48 | (member "Upgrade" connection :test 'string-equal)) 49 | (error-exit *400-message*)) 50 | ;; todo: validate Host: header 51 | ;; 404 if we don't recognize the requested resource 52 | (destructuring-bind (resource check-origin) 53 | (valid-resource-p (client-server client) resource-name) 54 | (unless resource 55 | (error-exit *404-message*)) 56 | (unless (funcall check-origin origin) 57 | (error-exit *403-message*)) 58 | 59 | (multiple-value-bind (acceptp rqueue origin handshake-resource protocol) 60 | (resource-accept-connection resource resource-name 61 | headers 62 | client) 63 | (declare (ignorable origin handshake-resource protocol)) 64 | (when (not acceptp) 65 | (error-exit *403-message*)) 66 | (setf (client-read-queue client) (or rqueue 67 | (resource-read-queue resource) 68 | (make-mailbox)) 69 | (client-resource client) resource) 70 | (%write-to-client client 71 | (string-to-shareable-octets 72 | ;; todo: Sec-WebSocket-Protocol, Sec-WebSocket-Extension 73 | (format nil 74 | "HTTP/1.1 101 Switching Protocols~AUpgrade: websocket~AConnection: Upgrade~ASec-WebSocket-Accept: ~A~A~A" 75 | +crlf+ +crlf+ +crlf+ 76 | (make-challenge-o7 key) 77 | +crlf+ +crlf+) 78 | :encoding :iso-8859-1)))) 79 | t))) 80 | 81 | 82 | (defun dispatch-message (client) 83 | (let ((opcode (message-opcode client)) 84 | (partial-message (partial-message client))) 85 | (setf (partial-message client) nil) 86 | (case opcode 87 | (#x1 ;; text message 88 | (let ((s (get-utf8-string-or-fail partial-message))) 89 | (client-enqueue-read client (list client (list :text s))))) 90 | (#x2 ;; binary message 91 | (let ((*print-length* 32) 92 | (v (get-octet-vector partial-message))) 93 | (client-enqueue-read client (list client (list :binary v)))))) 94 | (when (> (mailbox-count (client-read-queue client)) 95 | *max-handler-read-backlog*) 96 | ;; if server isn't processing events fast enough, disable the 97 | ;; reader temporarily and tell the handler 98 | (when (client-reader-active client) 99 | (client-disable-handler client :read t) 100 | (client-enqueue-read client (list client :flow-control)))))) 101 | 102 | (defun dispatch-control-message (client opcode) 103 | (let ((len (frame-length client)) 104 | (chunks (chunks client))) 105 | (case opcode 106 | (#x8 ;; close 107 | ;; if close frame has a body, it should be big-endian 16bit code 108 | (let* ((code (when (>= len 2) 109 | (dpb (read-octet chunks) (byte 8 8) 110 | (read-octet chunks)))) 111 | ;; optionally followed by utf8 text 112 | (message (when (> len 2) 113 | (get-utf8-string-or-fail chunks)))) 114 | ;; 1005 is status code to pass to applications when none was provided 115 | ;; by peer 116 | (error 'close-from-peer :status-code (or code 1005) 117 | :message message))) 118 | (#x9 ;; ping 119 | (let* ((v (get-octet-vector chunks)) 120 | (pong (pong-frame-for-protocol (client-websocket-version client) 121 | v))) 122 | (when pong 123 | (%write-to-client client pong)))) 124 | (#xa ;; pong 125 | (lg "got pong, body=~s~%" (get-octet-vector chunks))) 126 | (t (error 'fail-the-websockets-connection 127 | :status-code 1002 128 | :message (format nil "unknown control frame #x~2,'0x" opcode)))))) 129 | 130 | (defun dispatch-frame (client length) 131 | ;; control frames (opcodes 8+) can't be fragmented, so FIN=T 132 | ;; if 0= opcode 8) 138 | (if (or (not fin) (> length 125)) 139 | (error 'fail-the-websockets-connection 140 | :status-code 1002 141 | :message (if fin "fragmented control frame" 142 | "control frame too large")) 143 | (dispatch-control-message client opcode))) 144 | ;; continuation frame, add to partial message 145 | ((zerop opcode) 146 | (when (not (partial-message client)) 147 | ;; no message in progress, fail connection 148 | (error 'fail-the-websockets-connection 149 | :status-code 1002 150 | :message (format nil 151 | "continuation frame without start frame"))) 152 | (when (and (not fin) 153 | (> (+ length (buffer-size (partial-message client))) 154 | *max-read-message-size*)) 155 | (setf (partial-message client) nil) 156 | (error 'fail-the-websockets-connection 157 | :status-code 1009 158 | :message (format nil "message too large"))) 159 | (add-chunks (partial-message client) (chunks client)) 160 | (when fin 161 | (dispatch-message client))) 162 | ;; text/binary message 163 | ((or (= opcode 1) (= opcode 2)) 164 | ;; shouldn't have unfinished message 165 | (when (partial-message client) 166 | (error 'fail-the-websockets-connection 167 | :status-code 1002 168 | :message 169 | (format nil "start frame without finishing previous message"))) 170 | ;; check for too large partial message 171 | (when (and (not fin) 172 | (> length *max-read-message-size*)) 173 | (error 'fail-the-websockets-connection 174 | :status-code 1009 175 | :message (format nil "message too large"))) 176 | ;; start new message 177 | (setf (partial-message client) (make-instance 'chunk-buffer) 178 | (message-opcode client) opcode) 179 | (add-chunks (partial-message client) (chunks client)) 180 | (when fin 181 | (dispatch-message client))) 182 | (t 183 | (error 'fail-the-websockets-connection 184 | :status-code 1002 185 | :message (format nil "unknown data frame #x~2,'0x" opcode)))))) 186 | 187 | (defun protocol-7+-read-frame (client length mask) 188 | (cond 189 | ((and (>= (frame-opcode client) 8) 190 | (or (not (frame-fin client)) 191 | (> length 125))) 192 | (error 'fail-the-websockets-connection 193 | :status-code 1002 194 | :message (if (frame-fin client) 195 | "fragmented control frame" 196 | "control frame too large"))) 197 | ((> length *max-read-frame-size*) 198 | (error 'fail-the-websockets-connection 199 | :status-code 1009 200 | :message (format nil "frame too large")))) 201 | (next-reader-state 202 | client (octet-count-matcher length) 203 | (lambda (client) 204 | (when mask 205 | (mask-octets (chunks client) mask)) 206 | (dispatch-frame client length) 207 | (protocol-7+-start-frame client)))) 208 | 209 | (defun protocol-7+-read-mask (client length) 210 | ;; read 4 octet mask 211 | (next-reader-state 212 | client 213 | (octet-count-matcher 4) 214 | (lambda (client) 215 | (with-buffer-as-stream (client s) 216 | (let ((mask (make-array-ubyte8 4 :initial-element 0))) 217 | (loop for i below 4 218 | do (setf (aref mask i) (read-byte s))) 219 | (protocol-7+-read-frame client length mask)))))) 220 | 221 | (defun protocol-7+-extended-length (client octets masked) 222 | ;; read 2/8 octets, extended length 223 | (next-reader-state client 224 | (octet-count-matcher octets) 225 | (lambda (client) 226 | (with-buffer-as-stream (client s) 227 | (let ((length 0)) 228 | (loop for i below octets 229 | do (setf length 230 | (+ (* length 256) (read-byte s)))) 231 | (setf (frame-length client) length) 232 | (if masked 233 | (protocol-7+-read-mask client length) 234 | (protocol-7+-read-frame client length nil))))))) 235 | 236 | (defun protocol-7+-start-frame (client) 237 | ;; read 2 octets, opcode+flags and short length 238 | (next-reader-state 239 | client 240 | (octet-count-matcher 2) 241 | (lambda (client) 242 | (with-buffer-as-stream (client s) 243 | (let* ((opcode-octet (read-byte s)) 244 | (length-octet (read-byte s)) 245 | (fin (logbitp 7 opcode-octet)) 246 | (rsv (ldb (byte 3 4) opcode-octet)) 247 | (opcode (ldb (byte 4 0) opcode-octet)) 248 | (masked (logbitp 7 length-octet)) 249 | (length (ldb (byte 7 0) length-octet))) 250 | ;; TODO: move checks for continuation frames without start frame 251 | ;; here from dispatch-frame so we don't need to buffer data we 252 | ;; are just going to dump anyway 253 | (unless masked 254 | (error 'fail-the-websockets-connection 255 | :status-code 1002 256 | :message (format nil "client frames not masked"))) 257 | (unless (zerop rsv) 258 | (error 'fail-the-websockets-connection 259 | :status-code 1002 260 | :message (format nil "reserved bits ~3,'0b expected 000" rsv))) 261 | (setf (frame-opcode-octet client) opcode-octet 262 | (frame-opcode client) opcode 263 | (frame-length client) length 264 | (frame-fin client) fin) 265 | (cond 266 | ((> length 125) 267 | (protocol-7+-extended-length client 268 | (if (= length 126) 269 | 2 270 | 8) 271 | masked)) 272 | (masked 273 | (protocol-7+-read-mask client length)) 274 | (t 275 | (protocol-7+-read-frame client length nil)))))))) 276 | 277 | (defun protocol-7-parse-headers (client) 278 | (when (protocol-7+-handshake client "7" :sec-websocket-origin) 279 | (setf (client-websocket-version client) 7) 280 | (setf (client-connection-state client) :connected) 281 | (client-enqueue-read client (list client :connect)) 282 | (protocol-7+-start-frame client))) 283 | 284 | (defun protocol-8-parse-headers (client) 285 | (when (protocol-7+-handshake client "8" :sec-websocket-origin) 286 | (setf (client-websocket-version client) 8) 287 | (setf (client-connection-state client) :connected) 288 | (client-enqueue-read client (list client :connect)) 289 | (protocol-7+-start-frame client))) 290 | 291 | (defun protocol-13-parse-headers (client) 292 | (when (protocol-7+-handshake client "13" :origin) 293 | (setf (client-websocket-version client) 8) 294 | (setf (client-connection-state client) :connected) 295 | (client-enqueue-read client (list client :connect)) 296 | (protocol-7+-start-frame client))) 297 | 298 | (setf (gethash "7" *protocol-header-parsers*) 'protocol-7-parse-headers 299 | (gethash "8" *protocol-header-parsers*) 'protocol-8-parse-headers 300 | (gethash "13" *protocol-header-parsers*) 'protocol-13-parse-headers) 301 | 302 | (push 7 *supported-protocol-versions*) 303 | (push 8 *supported-protocol-versions*) 304 | (push 13 *supported-protocol-versions*) 305 | -------------------------------------------------------------------------------- /protocol.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | 4 | ;; predicates for determining if callback should be called or not 5 | 6 | ;; possibly these should have an external state rather than being closures, 7 | ;; so we can build them in advance? 8 | 9 | (defun octet-count-matcher (n) 10 | (let ((read 0)) 11 | (lambda (buffer start end) 12 | (declare (ignore buffer)) 13 | (let ((c (- end start))) 14 | (if (>= (+ read c) n) 15 | (+ (- n read) start) 16 | (progn (incf read c) nil)))))) 17 | 18 | (defun octet-pattern-matcher (octets &optional max-octets) 19 | (let ((matched 0) 20 | (read 0) 21 | (next (make-array (length octets) :initial-element 0 22 | :element-type 'fixnum))) 23 | ;; find next shortest sub-string that could be a match for current 24 | ;; position in octets. for example if we have matched "aaa" from "aaab" 25 | ;; and get another "a", we should reset match to "aa" rather than 26 | ;; starting over completely (and then add the new "a" to end up back at 27 | ;; "aaa" again) 28 | ;; -- probably should add a compiler macro to do this in advance for 29 | ;; the usual case of constant pattern? 30 | (loop 31 | with matches = 0 32 | for i from 1 below (length octets) 33 | when (= (aref octets matches) (aref octets i)) 34 | do (incf matches) 35 | else do (setf matches 0) 36 | do (setf (aref next i) matches)) 37 | (lambda (buffer start end) 38 | (flet ((match-octet (x) 39 | (loop 40 | do (if (= x (aref octets matched)) 41 | (return (incf matched)) 42 | (setf matched (aref next matched))) 43 | while (plusp matched)))) 44 | (loop 45 | for i from 0 46 | for bi from start below end 47 | do 48 | (incf read) 49 | (match-octet (aref buffer bi)) 50 | when (= matched (length octets)) 51 | return (values (1+ bi) read) 52 | when (and max-octets (> read max-octets)) 53 | do (error 'fail-the-websockets-connection 54 | :status-code 1009 55 | :message (format nil "message too large"))))))) 56 | 57 | 58 | (defun unsupported-protocol-version (client) 59 | ;; draft 7 suggests 'non-200' 60 | ;; 8 suggests "appropriate HTTP error code (such as 426 Upgrade Required)" 61 | ;; 14 suggests 400 62 | ;; and all 3 put list of supported versions in sec-websocket-version header 63 | ;; when we get one we don't recognize, so do that then close the connection 64 | (client-enqueue-write 65 | client 66 | (string-to-shareable-octets 67 | (format nil 68 | "HTTP/1.1 400 Bad Request~ASec-WebSocket-Version: ~{~s~^, ~}~A~A" 69 | +crlf+ *supported-protocol-versions* +crlf+ +crlf+ 70 | *supported-protocol-versions*) 71 | :encoding :utf-8)) 72 | (client-enqueue-write client :close) 73 | ;; is this needed after enqueueing :close? 74 | (client-disconnect client :read t :write t) 75 | (ignore-remaining-input client)) 76 | 77 | (defun send-error-and-close (client message) 78 | (client-enqueue-write client message) 79 | (client-enqueue-write client :close) 80 | (client-disconnect client :read t :write t) 81 | (ignore-remaining-input client)) 82 | 83 | (defun invalid-header (client) 84 | ;; just sending same error as unknown version for now... 85 | (unsupported-protocol-version client)) 86 | 87 | (defun match-resource-line (buffer) 88 | (next-reader-state 89 | buffer 90 | (octet-pattern-matcher #(13 10)) 91 | (alexandria:named-lambda resource-line-callback (x) 92 | (let ((request-line 93 | ;; fixme: process the buffers directly rather than this 94 | ;; complicated mess of nested streams and loop and coerce 95 | (with-buffer-as-stream (x s) 96 | (with-open-stream 97 | (s (flex:make-flexi-stream s)) 98 | (string-right-trim '(#\space #\return #\newline) 99 | (read-line s nil "")))))) 100 | (unless (every (lambda (c) (<= 32 (char-code c) 126)) request-line) 101 | (return-from resource-line-callback 102 | (invalid-header buffer))) 103 | (let ((s1 (position #\space request-line)) 104 | (s2 (position #\space request-line :from-end t))) 105 | (unless (and s1 s2 (> s2 (1+ s1)) 106 | (string= "GET " request-line :end2 (1+ s1)) 107 | ;; fixme: spec says "HTTP/1.1 or higher" 108 | ;; ignoring that possibilty for now.. 109 | (string= " HTTP/1.1" request-line :start2 s2)) 110 | (lg "got bad request line? ~s~%" request-line) 111 | (return-from resource-line-callback 112 | (invalid-header buffer))) 113 | (let* ((uri (subseq request-line (1+ s1) s2)) 114 | (? (position #\? uri :from-end t)) 115 | (query (when ? (subseq uri (1+ ?)))) 116 | (\:// (search "://" uri)) 117 | (scheme (when \:// (string-downcase (subseq uri 0 \://)))) 118 | (c/ (when (and scheme (> (length uri) (+ \:// 3))) 119 | (position #\/ uri :start (+ \:// 3)))) 120 | (resource-name (if (or c/ ?) 121 | (subseq uri (or c/ 0) ?) 122 | uri))) 123 | ;; websocket URIs must either start with / or 124 | ;; ws://.../ or wss://.../, and can't contain # 125 | ;; ... except draft 11-14 says "HTTP/HTTPS URI"? 126 | (unless (or (char= (char uri 0) #\/) 127 | (string= scheme "ws") 128 | (string= scheme "wss") 129 | (not (position #\# uri))) 130 | (return-from resource-line-callback 131 | (invalid-header buffer))) 132 | ;; fixme: decode %xx junk in url/query string? 133 | (lg "got request line ~s ? ~s~%" resource-name query) 134 | (setf (client-resource-name buffer) resource-name) 135 | (setf (client-query-string buffer) query)))) 136 | (match-headers buffer)))) 137 | 138 | ;;; websockets emulation using flash needs to be able to read a 139 | ;;; flash 'policy file' to connect 140 | (defparameter *policy-file-request* 141 | (concatenate '(vector (unsigned-byte 8)) 142 | (string-to-shareable-octets "") 143 | #(0))) 144 | 145 | (defun match-policy-file (buffer) 146 | (next-reader-state 147 | buffer 148 | (octet-pattern-matcher #(0)) 149 | (alexandria:named-lambda policy-file-callback (buffer) 150 | (let ((request (get-octet-vector (chunks buffer)))) 151 | (unless (and request (equalp request *policy-file-request*)) 152 | (lg "broken policy file request?~%") 153 | (return-from policy-file-callback 154 | (invalid-header buffer))) 155 | (lg "send policy file~%") 156 | (client-enqueue-write buffer *policy-file*) 157 | #++(%write-to-client buffer :close) 158 | #++(babel:octets-to-string *policy-file* :encoding :ascii) 159 | (client-disconnect buffer :read t :write t) 160 | (ignore-remaining-input buffer))))) 161 | 162 | (defun maybe-policy-file (buffer) 163 | (next-reader-state buffer 164 | (octet-count-matcher 2) 165 | (lambda (buffer) 166 | (if (eql (peek-octet (chunks buffer)) (char-code #\<)) 167 | (match-policy-file buffer) 168 | (match-resource-line buffer))))) 169 | 170 | (defun ignore-remaining-input (client) 171 | ;; just accept any input and junk it, for use when no more input expected 172 | ;; or we don't care... 173 | (next-reader-state client 174 | (lambda (b s e) 175 | (declare (ignore b)) 176 | (unless (= s e) 177 | e)) 178 | (lambda (x) (declare (ignore x)) 179 | #|| do nothing ||#))) 180 | 181 | 182 | (defun dispatch-protocols (client) 183 | (let* ((headers (client-connection-headers client)) 184 | (version (gethash :sec-websocket-version headers))) 185 | (cond 186 | ((and (not version) 187 | (gethash :sec-websocket-key1 headers) 188 | (gethash :sec-websocket-key2 headers)) 189 | ;; protocol 76/00 190 | (if *protocol-76/00-support* 191 | (protocol-76/00-nonce client) 192 | (unsupported-protocol-version client))) 193 | (version 194 | (if (gethash version *protocol-header-parsers*) 195 | (funcall (gethash version *protocol-header-parsers*) 196 | client) 197 | (unsupported-protocol-version client))) 198 | (t 199 | (lg "couldn't detect version? headers=~s~%" 200 | (alexandria:hash-table-alist headers)) 201 | (invalid-header client))))) 202 | 203 | 204 | (defun match-headers (client) 205 | (next-reader-state 206 | client (octet-pattern-matcher #(13 10 13 10)) 207 | (lambda (x) 208 | (let ((headers (with-buffer-as-stream (x s) 209 | (chunga:read-http-headers s)))) 210 | (setf (client-connection-headers client) (alexandria:alist-hash-table headers)) 211 | (dispatch-protocols client))))) 212 | 213 | 214 | ;;; fixme: these foo-for-protocol should probably be split out into 215 | ;;; separate functions, and stored in thunks in the client or looked 216 | ;;; up in a hash (or generic function) or whatever... 217 | (defun close-frame-for-protocol (protocol &key (code 1000) message) 218 | ;; not sure what 'protocol' should be for now... assuming protocol 219 | ;; version numbers (as integers) for now, with hixie-76/ietf-00 as 0 220 | (let ((utf8 (when message 221 | (string-to-shareable-octets message :encoding :utf-8))) 222 | (code (if (and (integerp code) (<= 0 code 65535) 223 | ;; MUST NOT send 1005 or 1006 224 | (/= code 1005) 225 | (/= code 1006)) 226 | code 227 | 1000))) 228 | (when (> (length utf8) 122) 229 | (setf utf8 nil)) 230 | (case protocol 231 | (0 *draft-76/00-close-frame*) 232 | ((7 8 13) 233 | (flex:with-output-to-sequence (s) 234 | ;; FIN + opcode 8 235 | (write-byte #x88 s) 236 | ;; MASK = 0, length 237 | (write-byte (+ 2 (length utf8)) s) 238 | ;; status code (optional, but we always send one) 239 | (write-byte (ldb (byte 8 8) code) s) 240 | (write-byte (ldb (byte 8 0) code) s) 241 | (when utf8 242 | (write-sequence utf8 s))))))) 243 | 244 | (defun pong-frame-for-protocol (protocol body) 245 | (when (> (length body) 125) 246 | (setf body nil)) 247 | (case protocol 248 | (0 nil) 249 | ((7 8 13) 250 | (flex:with-output-to-sequence (s) 251 | ;; FIN + opcode 8 252 | (write-byte #x8a s) 253 | ;; MASK = 0, length 254 | (write-byte (length body) s) 255 | (when body 256 | (write-sequence body s)))))) 257 | 258 | 259 | (defun build-frames (opcode octets frame-size) 260 | ;; sending non-simple vectors is slow, so don't want to use 261 | ;; w-o-t-sequence here... 262 | (loop for op = opcode then 0 263 | for octets-left = (length octets) then (- octets-left frame-octets) 264 | for fin = (if (<= octets-left frame-size) #x80 #x00) 265 | for offset = 0 then (+ offset frame-octets) 266 | for frame-octets = (min octets-left frame-size) 267 | for length-octets = (if (< frame-octets 126) 268 | 0 (if (< frame-octets 65536) 2 8)) 269 | collect (let ((a (make-array-ubyte8 (+ 2 length-octets frame-octets) 270 | :initial-element 0))) 271 | (setf (aref a 0) (logior fin op)) 272 | (cond 273 | ((< frame-octets 126) 274 | (setf (aref a 1) frame-octets)) 275 | ((< frame-octets 65536) 276 | (setf (aref a 1) 126) 277 | (setf (aref a 2) (ldb (byte 8 8) frame-octets)) 278 | (setf (aref a 3) (ldb (byte 8 0) frame-octets))) 279 | (t 280 | (setf (aref a 1) 127) 281 | (loop for i from 7 downto 0 282 | for j from 0 283 | do (setf (aref a (+ j 2)) 284 | (ldb (byte 8 (* i 8)) frame-octets))))) 285 | (when (plusp frame-octets) 286 | (if (typep octets '(simple-array (unsigned-byte 8) (*))) 287 | ;; duplicated so smart compilers can optimize the 288 | ;; common case 289 | (replace a octets :start1 (+ 2 length-octets) 290 | :start2 offset :end2 (+ offset frame-octets)) 291 | (replace a octets :start1 (+ 2 length-octets) 292 | :start2 offset :end2 (+ offset frame-octets)))) 293 | a) 294 | ;; check at end so we can send an empty frame if we want 295 | while (and (plusp octets-left) 296 | (/= octets-left frame-octets)))) 297 | 298 | (defun text-message-for-protocol (protocol message &key frame-size) 299 | (let* ((utf8 (if (stringp message) 300 | (string-to-shareable-octets message :encoding :utf-8) 301 | message)) 302 | (frame-size (or frame-size (1+ (length utf8))))) 303 | (case protocol 304 | (0 305 | ;; todo: decide if frame-size should apply to draft76/00 ? 306 | (list 307 | (flex:with-output-to-sequence (s) 308 | (write-byte #x00 s) 309 | (write-sequence utf8 s) 310 | (write-byte #xff s)))) 311 | ((7 8 13) 312 | (build-frames #x01 utf8 frame-size))))) 313 | 314 | (defun binary-message-for-protocol (protocol message &key frame-size) 315 | (let ((frame-size (or frame-size (1+ (length message))))) 316 | (case protocol 317 | (0 318 | (error "can't send binary messages to draft-00 connection")) 319 | ((7 8 13) 320 | (build-frames #x02 message frame-size))))) 321 | 322 | (defun write-to-client-close (client &key (code 1000) message) 323 | "Write a close message to client, and starts closing connection. If set, 324 | CODE must be a valid close code for current protocol version, and MESSAGE 325 | should be a string that encodes to fewer than 123 octets as UTF8 (it will 326 | be ignored otherwise)" 327 | (if (or code message) 328 | (%write-to-client client (list :close (close-frame-for-protocol 329 | (client-websocket-version client) 330 | :code code :message message))) 331 | (%write-to-client client :close))) 332 | 333 | (defun write-to-client-text (client message &key frame-size) 334 | "writes a text message to client. MESSAGE should either be a string, 335 | or an octet vector containing a UTF-8 encoded string. If FRAME-SIZE is 336 | set, breaks message into frames no larger than FRAME-SIZE octets." 337 | (loop for frame in (text-message-for-protocol 338 | (client-websocket-version client) 339 | message 340 | :frame-size frame-size) 341 | do (%write-to-client client frame))) 342 | 343 | 344 | (defun write-to-client-binary (client message &key frame-size) 345 | "writes a binary message to client. MESSAGE should either be an 346 | octet vector containing data to be sent. If FRAME-SIZE is set, breaks 347 | message into frames no larger than FRAME-SIZE octets." 348 | (loop for frame in (binary-message-for-protocol 349 | (client-websocket-version client) 350 | message 351 | :frame-size frame-size) 352 | do (%write-to-client client frame))) 353 | -------------------------------------------------------------------------------- /buffer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | ;;; chunks stored by chunk-buffer class 4 | (defclass buffer-chunk () 5 | ((vector :reader buffer-vector :initarg :vector) 6 | (start :reader buffer-start :initarg :start) 7 | (end :reader buffer-end :initarg :end))) 8 | 9 | (defmethod buffer-count ((buffer buffer-chunk)) 10 | (- (buffer-end buffer) (buffer-start buffer))) 11 | 12 | 13 | ;;; chunked buffer class 14 | ;;; stores a sequence of vectors + start/end 15 | ;;; intent is that one chunked-buffer is a single logical block of data 16 | ;;; and will be consumed all at once after it is accumulated 17 | ;;; operations: 18 | ;;; add a chunk (vector+bounds) 19 | ;;; -- check last chunk and combine if contiguous 20 | ;;; append another buffer 21 | ;;; -- combine last/first chunks if contiguous? 22 | ;;; read an octet 23 | ;;; convert to a contiguous vector 24 | ;;; (32bit xor for websockets masking stuff? maybe subclass?) 25 | ;;; convert (as utf8) to string 26 | ;;; call thunk with contents as (binary or text) stream? 27 | ;;; -- or maybe return a stream once it is implemented directly 28 | ;;; as a gray stream rather than a pile of concatenated 29 | ;;l and flexi-streams? 30 | ;;; ? map over octets/characters? 31 | ;;; todo: versions of octet-vector and string that don't clear buffer? 32 | ;;; (mostly for debugging) 33 | ;;; todo: option to build octet vector with extra space at beginning/end? 34 | ;;; (for example to make a pong response from a ping body) 35 | 36 | (defclass chunk-buffer () 37 | ((buffer-size :accessor buffer-size :initform 0) 38 | (chunks :accessor chunks :initform nil) 39 | ;; reference to last cons of chunks list, so we can append quickly 40 | (end-of-chunks :accessor end-of-chunks :initform nil))) 41 | 42 | (defmethod %get-chunks ((cb chunk-buffer)) 43 | (setf (end-of-chunks cb) nil) 44 | (values (shiftf (chunks cb) nil) 45 | (shiftf (buffer-size cb) 0))) 46 | 47 | (defmethod add-chunk ((cb chunk-buffer) vector start end) 48 | (if (chunks cb) 49 | ;; we already have some chunks, add at end 50 | (let ((last (end-of-chunks cb))) 51 | ;; if we are continuing previous buffer, just combine them 52 | (if (and (eq vector (buffer-vector (car last))) 53 | (= start (buffer-end (car last)))) 54 | (setf (slot-value (car last) 'end) end) 55 | ;; else add new chunk 56 | (progn 57 | (push (make-instance 'buffer-chunk :vector vector 58 | :start start :end end) 59 | (cdr last)) 60 | (pop (end-of-chunks cb))))) 61 | ;; add initial chunk 62 | (progn 63 | (push (make-instance 'buffer-chunk :vector vector 64 | :start start :end end) 65 | (chunks cb)) 66 | (setf (end-of-chunks cb) (chunks cb)))) 67 | (incf (buffer-size cb) (- end start))) 68 | 69 | ;;; fixme: should this make a new chunk-buffer? not clear more? reuse chunk-buffers better? 70 | (defmethod add-chunks ((cb chunk-buffer) (more chunk-buffer)) 71 | (loop for i in (%get-chunks more) 72 | do (add-chunk cb (buffer-vector i) (buffer-start i) (buffer-end i)))) 73 | 74 | (defmethod peek-octet ((cb chunk-buffer)) 75 | ;; fixme: decide how to handle EOF? 76 | (unless (chunks cb) 77 | (return-from peek-octet nil)) 78 | (let* ((chunk (car (chunks cb)))) 79 | (aref (buffer-vector chunk) (buffer-start chunk)))) 80 | 81 | (defmethod read-octet ((cb chunk-buffer)) 82 | ;; fixme: decide how to handle EOF? 83 | (unless (chunks cb) 84 | (return-from read-octet nil)) 85 | (let* ((chunk (car (chunks cb))) 86 | (octet (aref (buffer-vector chunk) (buffer-start chunk)))) 87 | (incf (slot-value chunk 'start)) 88 | (decf (buffer-size cb)) 89 | ;; if we emptied a chunk, get rid of it 90 | (when (= (buffer-start chunk) (buffer-end chunk)) 91 | (pop (chunks cb)) 92 | ;; and clear end ref as well if no more buffers 93 | (when (not (chunks cb)) 94 | (setf (end-of-chunks cb) nil))) 95 | octet)) 96 | 97 | (defun call-with-buffer-as-stream (buffer thunk) 98 | (let ((streams nil)) 99 | (unwind-protect 100 | (progn 101 | (setf streams 102 | (loop for i in (%get-chunks buffer) 103 | while i 104 | collect (flex:make-in-memory-input-stream 105 | (buffer-vector i) 106 | :start (buffer-start i) 107 | :end (buffer-end i)))) 108 | (with-open-stream (cs (apply #'make-concatenated-stream streams)) 109 | (funcall thunk cs))) 110 | (map 'nil 'close streams)))) 111 | 112 | (defmacro with-buffer-as-stream ((buffer stream) &body body) 113 | `(call-with-buffer-as-stream ,buffer 114 | (lambda (,stream) 115 | ,@body))) 116 | 117 | (defmethod get-octet-vector ((cb chunk-buffer)) 118 | (let* ((size (buffer-size cb)) 119 | (vector (make-array-ubyte8 size :initial-element 0)) 120 | (chunks (%get-chunks cb))) 121 | (loop for c in chunks 122 | for offset = 0 then (+ offset size) 123 | for size = (buffer-count c) 124 | for cv = (buffer-vector c) 125 | for cs = (buffer-start c) 126 | for ce = (buffer-end c) 127 | do (replace vector cv :start1 offset :start2 cs :end2 ce)) 128 | vector)) 129 | 130 | (defmethod get-utf8-string ((cb chunk-buffer) &key (errorp t) octet-end) 131 | (declare (ignorable errorp)) 132 | ;; not sure if it would be faster to pull through flexistreams 133 | ;; or make a separate octet vector and convert that with babel? 134 | ;; (best would be converting directly... possibly check for partial 135 | ;; character at beginning of buffer, find beginning in previous buffer 136 | ;; and only pass the valid part to babel, and add in the split char 137 | ;; by hand? might need to watch out for split over multiple buffers 138 | ;; if we get tiny chunks? (only when searching forward though, since 139 | ;; we should see the partial char in the first tiny chunk...) 140 | ;; (or maybe just implement our own converter since we only need utf8?)) 141 | (let* ((size (buffer-size cb)) 142 | (end (or octet-end size)) 143 | (vector (make-array-ubyte8 end :initial-element 0)) 144 | (chunks (%get-chunks cb))) 145 | (loop for c in chunks 146 | for offset = 0 then (+ offset size) 147 | for size = (buffer-count c) 148 | for cv of-type (simple-array (unsigned-byte 8) (*)) = (buffer-vector c) 149 | for cs = (buffer-start c) 150 | for ce = (buffer-end c) 151 | while (< offset end) 152 | do (replace vector cv :start1 offset :end1 end 153 | :start2 cs :end2 ce)) 154 | ;; todo: probably should wrap babel error in something that doesn't leak 155 | ;; implementation details (like use of babel) 156 | #++(babel:octets-to-string vector :encoding :utf-8 :errorp errorp) 157 | ;; babel isn't picky enough for the Autobahn test suite (it lets 158 | ;; utf16 surrogates through, so using flexistreams for now... 159 | (flex:octets-to-string vector :external-format :utf-8))) 160 | 161 | ;;; this doesn't really belong here, too lazy to make a websockets 162 | ;;; specific subclass for now though 163 | (defmethod mask-octets ((cb chunk-buffer) mask) 164 | (declare (type (simple-array (unsigned-byte 8) (*)) mask) 165 | (optimize speed)) 166 | ;; todo: declare types, optimize to run 32/64 bits at a time, etc... 167 | (loop with i of-type (integer 0 4) = 0 168 | for chunk in (chunks cb) 169 | for vec of-type (simple-array (unsigned-byte 8) (*)) = (buffer-vector chunk) 170 | for start fixnum = (buffer-start chunk) 171 | for end fixnum = (buffer-end chunk) 172 | do (loop for j from start below end 173 | do (setf (aref vec j) 174 | (logxor (aref vec j) 175 | (aref mask i)) 176 | i (mod (1+ i) 4))))) 177 | 178 | #++ 179 | (flet ((test-buf () 180 | (let ((foo (make-instance 'chunk-buffer)) 181 | (buf (string-to-shareable-octets "__"))) 182 | (add-chunk foo (string-to-shareable-octets "TEST" ) 0 4) 183 | (add-chunk foo (string-to-shareable-octets "test2") 0 5) 184 | (add-chunk foo buf 1 5) 185 | (add-chunk foo buf 5 (1- (length buf))) 186 | (add-chunk foo (string-to-shareable-octets "..test3") 2 7) 187 | foo))) 188 | (list 189 | (with-buffer-as-stream ((test-buf) s) 190 | (with-open-stream (s (flex:make-flexi-stream s)) 191 | (read-line s nil nil))) 192 | (babel:octets-to-string (get-octet-vector (test-buf))) 193 | (get-utf8-string (test-buf)))) 194 | 195 | #++ 196 | (let ((foo (make-instance 'chunk-buffer))) 197 | (add-chunk foo #(1 2 3 4) 0 3) 198 | (add-chunk foo #(10 11 12 13) 0 1) 199 | (add-chunk foo #(20 21 22 23) 0 3) 200 | (loop repeat 10 collect (read-octet foo))) 201 | 202 | 203 | 204 | 205 | 206 | ;;; buffered reader class 207 | ;;; reads from a socket (or stream?) until some condition is met 208 | ;;; (N octets read, specific pattern read (CR LF for example), etc) 209 | ;;; then calls a continuation callback, or calls error callback if 210 | ;;; connection closed, or too many octets read without condition being matched 211 | 212 | 213 | (defclass buffered-reader () 214 | (;; partially filled vector if any, + position of next empty octet 215 | (partial-vector :accessor partial-vector :initform nil) 216 | (partial-vector-pos :accessor partial-vector-pos :initform 0) 217 | ;; list of arrays + start,end values (in reverse order) 218 | (chunks :initform (make-instance 'chunk-buffer) :accessor chunks) 219 | ;; function to call with new data to determine if callback should 220 | ;; be called yet 221 | (predicate :initarg :predicate :accessor predicate) 222 | (callback :initarg :callback :accessor callback) 223 | (error-callback :initarg :error-callback :accessor error-callback))) 224 | 225 | ;;; allow calling some chunk-buffer functions on the buffered-reader 226 | ;;; and redirect to the slot... 227 | (defmethod %get-chunks ((b buffered-reader)) 228 | (%get-chunks (chunks b))) 229 | 230 | (define-condition fail-the-websockets-connection (error) 231 | ((code :initarg :status-code :initform nil :reader status-code) 232 | ;; possibly should include a verbose message for logging as well? 233 | (message :initarg :message :initform nil :reader status-message))) 234 | 235 | ;; should this be an error? 236 | (define-condition close-from-peer (error) 237 | ((code :initarg :status-code :initform 1000 :reader status-code) 238 | (message :initarg :message :initform nil :reader status-message))) 239 | 240 | ;;; low level implementations 241 | ;;; non-blocking iolib 242 | ;;; when buffer gets more data, it checks predicate and calls 243 | ;;; callback if matched. Callback sets new predicate+callback, and 244 | ;;; loop repeats until predicate doesn't match, at which point it 245 | ;;; waits for more input 246 | (defun add-reader-to-client (client &key (init-function 'maybe-policy-file)) 247 | (declare (optimize debug)) 248 | (setf (client-reader client) 249 | (let ((socket (client-socket client)) 250 | (buffer client)) 251 | (funcall init-function buffer) 252 | (lambda (fd event exception) 253 | (declare (ignore fd event exception)) 254 | (handler-bind 255 | ((error 256 | (lambda (c) 257 | (cond 258 | (*debug-on-server-errors* 259 | (invoke-debugger c)) 260 | (t 261 | (ignore-errors 262 | (lg "server error ~s, dropping connection~%" c)) 263 | (invoke-restart 'drop-connection)))))) 264 | (restart-case 265 | (handler-case 266 | (progn 267 | (when (or (not (partial-vector buffer)) 268 | (> (partial-vector-pos buffer) 269 | (- (length (partial-vector buffer)) 16))) 270 | (setf (partial-vector buffer) 271 | (make-array-ubyte8 2048) 272 | (partial-vector-pos buffer) 0)) 273 | (multiple-value-bind (_octets count) 274 | ;; fixme: decide on good max read chunk size 275 | (receive-from socket :buffer (partial-vector buffer) 276 | :start (partial-vector-pos buffer) 277 | :end (length (partial-vector buffer))) 278 | (declare (ignore _octets)) 279 | (when (zerop count) 280 | (error 'end-of-file)) 281 | (let* ((start (partial-vector-pos buffer)) 282 | (end (+ start count)) 283 | (failed nil)) 284 | (loop for match = (funcall (predicate buffer) 285 | (partial-vector buffer) 286 | start end) 287 | do 288 | (add-chunk (chunks buffer) 289 | (partial-vector buffer) 290 | start (or match end)) 291 | (when match 292 | (setf start match) 293 | (funcall (callback buffer) buffer)) 294 | while (and (not failed) match (>= end start))) 295 | ;; todo: if we used up all the data that 296 | ;; was read, dump the buffer in a pool or 297 | ;; something so we don't hold a buffer in 298 | ;; ram for each client while waiting for 299 | ;; data 300 | (setf (partial-vector-pos buffer) end)))) 301 | ;; protocol errors 302 | (fail-the-websockets-connection (e) 303 | (when (eq (client-connection-state client) :connected) 304 | ;; probably can send directly since running from 305 | ;; server thread here? 306 | (write-to-client-close client :code (status-code e) 307 | :message (status-message e))) 308 | (setf (client-connection-state client) :failed) 309 | (client-enqueue-read client (list client :eof)) 310 | (lg "failed connection ~s / ~s : ~s ~s~%" 311 | (client-host client) (client-port client) 312 | (status-code e) (status-message e)) 313 | (client-disconnect client :read t 314 | :write t)) 315 | (close-from-peer (e) 316 | (when (eq (client-connection-state client) :connected) 317 | (write-to-client-close client)) 318 | (lg "got close frame from peer: ~s / ~s~%" 319 | (status-code e) (status-message e)) 320 | (setf (client-connection-state client) :cloed) 321 | ;; probably should send code/message to resource handlers? 322 | (client-enqueue-read client (list client :eof)) 323 | (client-disconnect client :read t 324 | :write t)) 325 | ;; close connection on socket/read errors 326 | (end-of-file () 327 | (client-enqueue-read client (list client :eof)) 328 | (lg "closed connection ~s / ~s~%" (client-host client) 329 | (client-port client)) 330 | (client-disconnect client :read t 331 | :write t)) 332 | (socket-connection-reset-error () 333 | (client-enqueue-read client (list client :eof)) 334 | (lg "connection reset by peer ~s / ~s~%" 335 | (client-host client) 336 | (client-port client)) 337 | (client-disconnect client :read t)) 338 | ;; ... add error handlers 339 | ) 340 | (drop-connection () 341 | (client-disconnect client :read t :write t :abort t))))))) 342 | (client-enable-handler client :read t)) 343 | 344 | (defun next-reader-state (buffer predicate callback) 345 | (setf (predicate buffer) predicate 346 | (callback buffer) callback)) 347 | -------------------------------------------------------------------------------- /client.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ws) 2 | 3 | (defparameter *max-write-backlog* 16 4 | "Max number of queued write frames before dropping a client.") 5 | 6 | (defclass client (buffered-reader) 7 | ((server :initarg :server :reader client-server 8 | :documentation "The instance of WS:SERVER that owns this 9 | client.") 10 | (resource :initarg :resource :initform nil :accessor client-resource 11 | :documentation "The resource object the client has 12 | requested-- Not the string, but the object.") 13 | (port :initarg :port :reader client-port) 14 | ;; host address as a string 15 | (host :initarg :host :reader client-host) 16 | ;; internal version, in some unspecified format 17 | (%host :initarg :%host :reader %client-host) 18 | (server-hook :initarg :server-hook :reader %client-server-hook 19 | :documentation "Function to call to send a command to 20 | the network thread from other threads") 21 | (socket :initarg :socket :reader client-socket 22 | :documentation "Bidirectional socket stream used for communicating with 23 | the client.") 24 | (read-closed :initform nil :accessor client-read-closed 25 | :documentation "Flag indicates read side of the 26 | connection is closed") 27 | (write-closed :initform nil :accessor client-write-closed 28 | :documentation "Flag indicates write side of the 29 | connection is closed") 30 | (closed :initform nil :accessor client-socket-closed 31 | :documentation "Flag indicates connection is closed") 32 | 33 | (write-buffer :initform nil :accessor client-write-buffer 34 | :documentation "Buffer being written currently, if 35 | last write couldn't send whole thing") 36 | (write-offset :initform 0 :accessor client-write-offset 37 | :documentation "Offset into write-buffer if 38 | write-buffer is set") 39 | (write-queue :initform (make-mailbox) 40 | :reader client-write-queue 41 | :documentation "Queue of buffers (octet vectors) to 42 | write, or :close to kill connection :enable-read to 43 | reenable reader after being disabled for flow 44 | control (mailbox instead of queue since it tracks 45 | length).") 46 | (read-queue :initform (make-mailbox) 47 | ;; possibly should have separate writer? 48 | :accessor client-read-queue 49 | :documentation "queue of decoded lines/frames") 50 | (connection-state :initform :connecting :accessor client-connection-state 51 | :documentation "State of connection: 52 | :connecting when initially created 53 | :headers while reading headers, 54 | :connected after server handshake sent 55 | :failed after an error has occurred and further input/output will be ignored 56 | :closing when close has been sent but not received from peer (input is still 57 | valid, but no more output will be sent)") 58 | (reader :initform nil :accessor client-reader 59 | :documentation "Read handler for this queue/socket") 60 | (handler-data :initform nil :accessor client-handler-data 61 | :documentation "Space for handler to store connection 62 | specific data.") 63 | ;; probably don't need to hold onto these for very long, but easier 64 | ;; to store here than pass around while parsing handshake 65 | (connection-headers :initform nil :accessor client-connection-headers) 66 | ;; 'resource name' and 'query' parts of request URI 67 | ;; (ws://host?host 68 | (resource-name :initform nil :accessor client-resource-name) 69 | (query-string :initform nil :accessor client-query-string) 70 | (websocket-version :initform nil :accessor client-websocket-version) 71 | ;; internal slots used for message/frame assembly 72 | (partial-message :initform nil :accessor partial-message) 73 | (message-opcode :initform nil :accessor message-opcode) 74 | (frame-opcode-octet :initform nil :accessor frame-opcode-octet) 75 | (frame-opcode :initform nil :accessor frame-opcode) 76 | (frame-fin :initform nil :accessor frame-fin) 77 | (frame-length :initform nil :accessor frame-length) 78 | ;; used by resource handler to mark a rejected connection, so already 79 | ;; queued messages can be dropped 80 | (connection-rejected :initform nil :accessor client-connection-rejected)) 81 | (:documentation "Per-client data used by a WebSockets server.")) 82 | 83 | (defmethod client-reader-active ((client client)) 84 | (iolib.multiplex::fd-monitored-p (server-event-base (client-server client)) 85 | (socket-os-fd (client-socket client)) :read)) 86 | 87 | (defmethod client-writer-active ((client client)) 88 | (iolib.multiplex::fd-monitored-p (server-event-base (client-server client)) 89 | (socket-os-fd (client-socket client)) :write)) 90 | 91 | (defmethod client-error-active ((client client)) 92 | (iolib.multiplex::fd-has-error-handler-p (server-event-base (client-server client)) 93 | (socket-os-fd (client-socket client)))) 94 | 95 | (deftype client-write-control-keyword () '(member :close :enable-read)) 96 | 97 | (defun special-client-write-value-p (value) 98 | "Certain values, like :close and :enable-read, are special symbols 99 | that may be passed to WRITE-TO-CLIENT or otherwise enqueued on the 100 | client's write queue. This predicate returns T if value is one of 101 | those special values" 102 | (typep value 'client-write-control-keyword)) 103 | 104 | (defgeneric client-enable-handler (client &key read write error) 105 | (:documentation "Enables the read, write, or error handler for a a 106 | client. Once a read handler is set up, the client can handle the 107 | handshake coming in from the client.")) 108 | 109 | (defmethod client-enable-handler ((client client) &key read write error) 110 | (lg "enable handlers for ~s:~s ~s ~s ~s~%" 111 | (client-host client) (client-port client) read write error) 112 | (when (and (not (client-socket-closed client)) 113 | (socket-os-fd (client-socket client))) 114 | (let ((fd (socket-os-fd (client-socket client)))) 115 | 116 | (when (and write 117 | (not (client-writer-active client)) 118 | (not (client-write-closed client))) 119 | (try-write-client client)) 120 | (when read (lg "enable read ~s ~s ~s~%" 121 | fd 122 | (client-reader-active client) 123 | (client-read-closed client))) 124 | (when (and read 125 | (not (client-reader-active client)) 126 | (not (client-read-closed client))) 127 | (set-io-handler (server-event-base (client-server client)) 128 | fd 129 | :read (client-reader client)) 130 | #++(setf (client-reader-active client) t)) 131 | 132 | (when (and error (not (client-error-active client))) 133 | (error "error handlers not implemented yet..."))))) 134 | 135 | (defgeneric client-disable-handler (client &key read write error) 136 | (:documentation "Stop listening for READ, WRITE, or ERROR events on the socket for 137 | the given client object. ")) 138 | 139 | (defmethod client-disable-handler ((client client) &key read write error) 140 | (lg "disable handlers for ~s:~s ~s ~s ~s~%" 141 | (client-host client) (client-port client) read write error) 142 | (let ((fd (socket-os-fd (client-socket client)))) 143 | (when (and write (client-writer-active client)) 144 | (iolib:remove-fd-handlers (server-event-base (client-server client)) fd :write t)) 145 | 146 | (when read (lg "disable read ~s ~s ~s~%" 147 | fd 148 | (client-reader-active client) 149 | (client-read-closed client))) 150 | 151 | (when (and read (client-reader-active client)) 152 | (remove-fd-handlers (server-event-base (client-server client)) fd :read t)) 153 | 154 | (when (and error (client-error-active client)) 155 | (error "error handlers not implemented yet...")))) 156 | 157 | (defgeneric client-disconnect (client &key read write close abort) 158 | (:documentation "Shutdown 1 or both sides of a connection, close it 159 | if both sides shutdown")) 160 | 161 | (defmethod client-disconnect ((client client) &key read write close abort) 162 | "shutdown 1 or both sides of a connection, close it if both sides shutdown" 163 | (declare (optimize (debug 3))) 164 | (lg "disconnect for ~s:~s ~s ~s / ~s ~s~%" 165 | (client-host client) (client-port client) read write close abort) 166 | (unless (client-socket-closed client) 167 | (macrolet ((ignore-some-errors (&body body) 168 | `(handler-case 169 | (progn ,@body) 170 | (socket-not-connected-error () 171 | (lg "enotconn ~s ~s ~s~%" ,(format nil "~s" body) 172 | (client-port client) fd) 173 | nil) 174 | (isys:epipe () 175 | (lg "epipe in disconnect~%") 176 | nil) 177 | (isys:enotconn () 178 | (lg "enotconn in shutdown/close?") 179 | nil)))) 180 | (let* ((socket (client-socket client)) 181 | (fd (socket-os-fd socket))) 182 | (when (or read close abort) 183 | ;; is all of this valid/useful for abort? 184 | (unless (client-read-closed client) 185 | (ignore-some-errors (client-disable-handler client :read t)) 186 | (ignore-some-errors (shutdown socket :read t)) 187 | (setf (client-read-closed client) t))) 188 | (when (or write close abort) 189 | ;; is all of this valid/useful for abort? 190 | (unless (client-write-closed client) 191 | (ignore-some-errors (client-disable-handler client :write t)) 192 | (ignore-some-errors (shutdown socket :write t)) 193 | (setf (client-write-closed client) t))) 194 | (when (or close abort 195 | (and (client-read-closed client) 196 | (client-write-closed client))) 197 | ;; shouldn't need to remove read/write handlers by this point? 198 | (when (or (client-reader-active client) 199 | (client-writer-active client) 200 | (client-error-active client)) 201 | (ignore-some-errors (remove-fd-handlers (server-event-base (client-server client)) 202 | fd :read t :write t :error t))) 203 | (ignore-some-errors (close socket :abort abort)))))) 204 | 205 | (let ((resource (client-resource client))) 206 | (when (and resource 207 | (or close abort (client-read-closed client))) 208 | (lg "disconnect client from resource ~s:~s~%" 209 | (client-host client) (client-port client)) 210 | ;; should this clear client-resource too? 211 | (resource-client-disconnected resource client) 212 | (setf (client-resource client) nil) 213 | (unless (client-write-closed client) 214 | (%write-to-client client :close)))) 215 | 216 | ;; not sure if this actually needs to be separate from previous 217 | ;; check, need to figure out whether there can actually still be 218 | ;; useful data waiting to be sent that will be received by the peer... 219 | (when (and (or close abort 220 | (and (client-read-closed client) 221 | (client-write-closed client))) 222 | (not (client-socket-closed client))) 223 | (lg "removing client ~s (closed already? ~A)~%" (client-port client) (client-socket-closed client)) 224 | (setf (client-socket-closed client) t) 225 | (remhash client (server-clients (client-server client)))) 226 | (lg "<= (client-write-offset client) 417 | (length (client-write-buffer client))) 418 | (setf (client-write-buffer client) nil)))) 419 | 420 | ;; if we didn't write the entire buffer, make sure the writer is 421 | ;; enabled, and exit the loop 422 | 423 | ;; > But shouldn't we ensure that the writer is enabled 424 | ;; > regardless of whether iolib manages to write out the 425 | ;; > entire buffer? -- RED 426 | (when (client-write-buffer client) 427 | (enable) 428 | (loop-finish)) 429 | 430 | (when (mailbox-empty-p (client-write-queue client)) 431 | (client-disable-handler client :write t) 432 | (loop-finish)))) 433 | 434 | (isys:ewouldblock () 435 | (enable) 436 | nil) 437 | (isys:epipe () 438 | ;; client closed conection, so drop it... 439 | (lg "epipe~%") 440 | (client-enqueue-read client (list client :dropped)) 441 | (client-disconnect client :close t)) 442 | (socket-connection-reset-error () 443 | (lg "connection reset~%") 444 | (client-enqueue-read client (list client :dropped)) 445 | (client-disconnect client :close t))))))) 446 | 447 | 448 | (defun %client-enqueue-write-or-kill (frame client) 449 | (unless (client-write-closed client) 450 | (cond 451 | ((symbolp frame) 452 | ;; don't count control messages against limit for now 453 | (mailbox-send-message (client-write-queue client) frame)) 454 | ((> (mailbox-count (client-write-queue client)) 455 | *max-write-backlog*) 456 | (lg "client write backlog = ~s, killing connection~%" 457 | (mailbox-count (client-write-queue client))) 458 | (funcall (%client-server-hook client) 459 | (lambda () 460 | (client-disconnect client :abort t) 461 | (client-enqueue-read client (list client :dropped)) 462 | (mailbox-receive-pending-messages 463 | (client-write-queue client))))) 464 | (t 465 | (mailbox-send-message (client-write-queue client) frame))))) 466 | 467 | (defun client-enqueue-read (client data) 468 | "Adds a piece of data to the client's read-queue so that it may be 469 | read and processed." 470 | (mailbox-send-message (client-read-queue client) data)) 471 | 472 | (defun client-dequeue-read (client) 473 | "Non-blocking call to dequeue a piece of data from a client' read-queue." 474 | (mailbox-receive-message-no-hang (client-read-queue client))) 475 | 476 | 477 | --------------------------------------------------------------------------------