eschulte pushed a commit to branch master
in repository elpa.
commit c679ba9eb908d047df71383775eec916f32bae5f
Author: Eric Schulte <schulte.e...@gmail.com>
Date: Mon Jan 6 22:14:41 2014 -0700
beginning to implement web-socket support
---
NOTES | 8 ++++++--
examples/9-web-socket.el | 41 +++++++++++++++++++++++++++++++++++++++++
web-server-test.el | 5 +++++
web-server.el | 23 ++++++++++++++++++-----
4 files changed, 70 insertions(+), 7 deletions(-)
diff --git a/NOTES b/NOTES
index 09c7aa6..9c6e3a2 100644
--- a/NOTES
+++ b/NOTES
@@ -1,7 +1,11 @@
-*- org -*-
* Notes
-* Tasks [10/24]
+* Tasks [10/25]
+** TODO web sockets
+- http://en.wikipedia.org/wiki/WebSocket
+- http://tools.ietf.org/html/rfc6455
+
** more examples [0/4]
*** TODO Org-mode agenda
Already exists as part of org-ehtml.
@@ -134,7 +138,7 @@ e.g., parameter strings
- [X] parse urlencoded post data
- [X] think about defaulting to (name . content) for form elements
- [X] maybe don't require a non-nil return to cancel the connection,
- instead only keep open if :keep-open is returned
+ instead only keep open if =:keep-alive= is returned
- [X] function to send a file (with mime handling)
- [X] send a 404 with some default text
diff --git a/examples/9-web-socket.el b/examples/9-web-socket.el
new file mode 100644
index 0000000..1b19b6c
--- /dev/null
+++ b/examples/9-web-socket.el
@@ -0,0 +1,41 @@
+;;; web-sockets.el --- communicate via web-sockets
+
+(defvar web-socket-page "<html>
+<head>
+<script type=\"text/javascript\">
+var ws;
+function connect(){
+ ws = new WebSocket(\"ws://localhost:9999/\");
+
+ ws.onopen = function() { alert(\"connected\"); ws.send(\"heyo\"); };
+ ws.onmessage = function(msg) { alert(msg.data); };
+ ws.onclose = function() { alert(\"connection closed\"); };
+}
+
+function message(){ ws.send(\"message\"); }
+</script>
+</head>
+<body>
+<a href=\"javascript:connect()\">connect</a>
+<a href=\"javascript:message()\">message</a>
+</body>
+</html>")
+
+(defun web-socket-server (request)
+ (with-slots (process headers) request
+ (message "hd:%S" headers)
+ (cond
+ ((assoc :SEC-WEBSOCKET-KEY headers)
+ (ws-response-header process 101
+ (cons "Upgrade" "websocket")
+ (cons "Connection" "upgrade")
+ (cons "Sec-WebSocket-Accept"
+ (ws-web-socket-handshake
+ (cdr (assoc :SEC-WEBSOCKET-KEY headers)))))
+ (set-process-filter process 'ws-web-socket-filter)
+ :keep-alive)
+ (t
+ (ws-response-header process 200 '("Content-type" . "text/html"))
+ (process-send-string process web-socket-page)))))
+
+(ws-start '(((:GET . ".*") . web-socket-server)) 9999)
diff --git a/web-server-test.el b/web-server-test.el
index 8f6f01c..5c03720 100644
--- a/web-server-test.el
+++ b/web-server-test.el
@@ -243,4 +243,9 @@ Content-Type: application/octet-stream
(cdr (assoc "file" (headers request))))))))
(ws-stop server))))
+(ert-deftest ws/web-socket-handshake-rfc-example ()
+ "Ensure that `ws-web-socket-handshake' conforms to the example in RFC6455."
+ (should (string= (ws-web-socket-handshake "dGhlIHNhbXBsZSBub25jZQ==")
+ "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=")))
+
(provide 'web-server-test)
diff --git a/web-server.el b/web-server.el
index 5d01501..080023a 100644
--- a/web-server.el
+++ b/web-server.el
@@ -55,6 +55,9 @@
(defvar ws-log-time-format "%Y.%m.%d.%H.%M.%S.%N"
"Logging time format passed to `format-time-string'.")
+(defvar ws-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11"
+ "This GUID is defined in RFC6455.")
+
;;;###autoload
(defun ws-start (handlers port &optional log-buffer &rest network-args)
"Start a server using HANDLERS and return the server object.
@@ -208,8 +211,8 @@ function.
(when (not (eq (catch 'close-connection
(if (ws-parse-request request)
(ws-call-handler request handlers)
- :keep-open))
- :keep-open))
+ :keep-alive))
+ :keep-alive))
(setq requests (cl-remove-if (lambda (r) (eql proc (process r)))
requests))
(delete-process proc))))))
@@ -245,7 +248,7 @@ Return non-nil only when parsing is complete."
(progn
(setcdr (last headers)
(list (ws-parse-multipart/form process
- (substring pending
index next-index))))
+ (substring pending index next-index))))
;; Boundary suffixed by "--" indicates end of the headers.
(when (and (> (length pending) (+ tmp 2))
(string= (substring pending tmp (+ tmp 2))
"--"))
@@ -300,16 +303,22 @@ Return non-nil only when parsing is complete."
(apply #'format msg args)))))
(apply #'ws-send-500 proc msg args)))
+;; TODO: http://tools.ietf.org/html/rfc6455#section-5.2
+(defun ws-web-socket-filter (proc string)
+ "Web socket filter to pass whole frames to the client.
+See RFC6455."
+ (message "ws:%S" string))
+
;;; Convenience functions to write responses
-(defun ws-response-header (proc code &rest header)
+(defun ws-response-header (proc code &rest headers)
"Send the headers for an HTTP response to PROC.
Currently CODE should be an HTTP status code, see
`ws-status-codes' for a list of known codes."
(let ((headers
(cons
(format "HTTP/1.1 %d %s" code (cdr (assoc code ws-status-codes)))
- (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) header))))
+ (mapcar (lambda (h) (format "%s: %s" (car h) (cdr h))) headers))))
(setcdr (last headers) (list "" ""))
(process-send-string proc (mapconcat #'identity headers "\r\n"))))
@@ -352,5 +361,9 @@ If so return PATH, if not return nil."
(string= parent (substring expanded 0 (length parent)))
expanded)))
+(defun ws-web-socket-handshake (key)
+ "Perform the handshake defined in RFC6455."
+ (base64-encode-string (sha1 (concat (ws-trim key) ws-guid) nil nil 'binary)))
+
(provide 'web-server)
;;; web-server.el ends here
