[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Allow websocket over http by adding fallback.
|
From: |
Jan Nieuwenhuizen |
|
Subject: |
[PATCH] Allow websocket over http by adding fallback. |
|
Date: |
Tue, 16 Aug 2016 17:06:20 +0200 |
Hi David,
Thanks for your websocket implementation! Before actually using it I
found that I would like to use the nodejs (?) convention to reuse the
http socket for websocket traffic.
I found a way for websockets to share the http socket, see attached
patch; it requires some duplication of (web server) because it lacks
hooks for such use.
What do you think, would you like to help clean this up on the Guile
side?
Greetings,
Jan
>From 1d4cead12c0451ef1d35a1610701aa010f82aa03 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <address@hidden>
Date: Tue, 16 Aug 2016 16:59:21 +0200
Subject: [PATCH] Allow websocket over http by adding fallback.
* web/socket/server.scm (serve-client): Add optional parameter FALLBACK.
(run-socket-server): Likewise. Rename from (run-socket). Allows use of ((web
server) run-server).
* test.scm: Update caller.
* test-http+ws.scm: New file.
* README: Mention ws over http example.
---
README | 11 +++++-
test-http+ws.scm | 107 ++++++++++++++++++++++++++++++++++++++++++++++++++
test.scm | 2 +-
web/socket/server.scm | 96 +++++++++++++++++++++++---------------------
4 files changed, 170 insertions(+), 46 deletions(-)
create mode 100644 test-http+ws.scm
diff --git a/README b/README
index 181a537..ba77386 100644
--- a/README
+++ b/README
@@ -11,5 +11,14 @@ Run the example server:
GUILE_LOAD_PATH="$PWD:$GUILE_LOAD_PATH" guile test.scm
#+END_SRC
-Then, open the =text.html= page in your web browser. If everything
+Then, open the =test.html= page in your web browser. If everything
works, "!ereht ,olleH" will be written to the JavaScript console.
+
+Run example http+websocket server:
+
+#+BEGIN_SRC sh
+ GUILE_LOAD_PATH="$PWD:$GUILE_LOAD_PATH" guile test-http+ws.scm
+#+END_SRC
+
+Then, visit [[http://localhost:9090][http:u//localhost:9090]] in your web
browser. If everything
+works, "!ereht ,olleH" will be printed as a greeting on the web page.
diff --git a/test-http+ws.scm b/test-http+ws.scm
new file mode 100644
index 0000000..4279318
--- /dev/null
+++ b/test-http+ws.scm
@@ -0,0 +1,107 @@
+(use-modules (ice-9 optargs)
+ (web http)
+ (web request)
+ (web response)
+ (web server)
+ (web server http)
+ (web socket server)
+ (web uri))
+
+;; Respond to text messages by reversing the message. Respond to
+;; binary messages with "hello".
+(define (ws-handler data)
+ (if (string? data)
+ (string-reverse data)
+ "WS:hello"))
+
+(define (not-found request)
+ (format (current-error-port) "not found: ~S\n" (request-path-components
request))
+ (values (build-response #:code 404)
+ (string-append "Resource not found: "
+ (uri->string (request-uri request)))))
+
+(define (http-handler request body)
+ (let ((components (map string->symbol (request-path-components request))))
+ (cond
+ ((null? components)
+ (format (current-error-port) "serving index.html\n")
+ (values '((content-type . (text/html)))
+ "<html>
+<head>
+<script type='text/javascript'>
+ var ws_url = 'ws://' + window.location.host;
+ var ws = new WebSocket (ws_url);
+ console.log ('initialized websocket');
+ ws.onmessage = function (evt) {
+ console.log ('received message');
+ console.log (evt.data);
+ var response = document.getElementById ('response');
+ response.innerHTML = evt.data;
+ };
+ ws.onopen = function () {
+ console.log ('connected');
+ ws.send ('Hello, there!');
+ }
+ ws.onclose = function () {
+ console.log ('closed websocket');
+ }
+</script>
+</head>
+<body>
+<h1 id='greet'>Hi</h1>
+<h1 id='response'></h1>
+
+</body>
+</html>"))
+ (else
+ (not-found request)))))
+
+;; FIXME: extracted from ((web server) serve-one-client
+;; what about STATE?
+(define (handle-one-http-request handler impl server client request state)
+ ;;(debug-elapsed 'read-client)
+ (when client
+ (let ((body (read-request-body request)))
+ (call-with-values
+ (lambda ()
+ (handle-request handler request body state))
+ (lambda (response body state)
+ ;;(debug-elapsed 'handle-request)
+ (write-client impl server client response body)
+ ;;(debug-elapsed 'write-client)
+ state)))
+ state))
+
+(when (equal? (effective-version) "2.0")
+ (module-define! (current-module) 'make-server-impl (@@ (web server)
make-server-impl))
+ (module-define! (current-module) 'server-impl-open (@@ (web server)
server-impl-open))
+ (module-define! (current-module) 'server-impl-read (@@ (web server)
server-impl-read))
+ (module-define! (current-module) 'server-impl-write (@@ (web server)
server-impl-write))
+ (module-define! (current-module) 'server-impl-close (@@ (web server)
server-impl-close)))
+
+(define* (open-http #:optional (host "127.0.0.1") (port 9090))
+ (let* ((impl (lookup-server-impl 'http))
+ (open-params (list #:host host #:port port))
+ (server (open-server impl open-params)))
+ (make-server-impl
+ 'opened-http
+ (lambda () server)
+ (server-impl-read impl)
+ (server-impl-write impl)
+ (server-impl-close impl))))
+
+(define* (serve #:optional (impl (open-http)))
+ (let* ((server ((server-impl-open impl)))
+ (sock ((@@ (web server http) http-socket) server))
+ (state '())
+ (fallback
+ (lambda (client-socket request)
+ (handle-one-http-request http-handler impl server client-socket
request state)
+ (close client-socket))))
+ (format (current-error-port) "serving ...\n")
+ (run-socket-server ws-handler sock fallback)))
+
+(define (request-path-components request)
+ (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(serve)
diff --git a/test.scm b/test.scm
index 92e61cf..1268b15 100644
--- a/test.scm
+++ b/test.scm
@@ -7,4 +7,4 @@
(string-reverse data)
"hello"))
-(run-server handler (make-server-socket #:port 9090))
+(run-socket-server handler (make-server-socket #:port 9090))
diff --git a/web/socket/server.scm b/web/socket/server.scm
index cd52220..482680d 100644
--- a/web/socket/server.scm
+++ b/web/socket/server.scm
@@ -33,7 +33,7 @@
#:use-module (web socket frame)
#:use-module (web socket utils)
#:export (make-server-socket
- run-server))
+ run-socket-server))
;; See section 4.2 for explanation of the handshake.
(define (read-handshake-request client-socket)
@@ -66,10 +66,11 @@ string."
(match (accept server-socket)
((client-socket . _) client-socket)))
-(define (serve-client client-socket handler)
+(define* (serve-client client-socket handler #:optional fallback)
"Serve client connected via CLIENT-SOCKET by performing the HTTP
handshake and listening for control and data frames. HANDLER is
-called for each complete message that is received."
+called for each complete message that is received. Upon receiving a
+non-websocket request, FALLBACK is invoked."
(define (handle-data-frame type data)
(let* ((result (handler (match type
('text (utf8->string data))
@@ -89,46 +90,52 @@ called for each complete message that is received."
(and (not (port-eof? client-socket))
(read-frame client-socket)))
- ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
- (let* ((request (read-handshake-request client-socket))
- (client-key (assoc-ref (request-headers request) 'sec-websocket-key))
- (response (make-handshake-response client-key)))
- (write-response response client-socket)
- (let loop ((fragments '())
- (type #f))
- (let ((frame (read-frame-maybe)))
- (cond
- ;; EOF - port is closed.
- ((not frame)
- (close-port client-socket))
- ;; Per section 5.4, control frames may appear interspersed
- ;; along with a fragmented message.
- ((close-frame? frame)
- ;; Per section 5.5.1, echo the close frame back to the
- ;; client before closing the socket. The client may no
- ;; longer be listening.
- (false-if-exception
- (write-frame (make-close-frame (frame-data frame)) client-socket))
- (close-port client-socket))
- ((ping-frame? frame)
- ;; Per section 5.5.3, a pong frame must include the exact
- ;; same data as the ping frame.
- (write-frame (make-pong-frame (frame-data frame)) client-socket)
- (loop fragments type))
- ((pong-frame? frame) ; silently ignore pongs
- (loop fragments type))
- ((first-fragment-frame? frame) ; begin accumulating fragments
- (loop (list frame) (frame-type frame)))
- ((final-fragment-frame? frame) ; concatenate all fragments
- (handle-data-frame type (frame-concatenate (reverse fragments)))
- (loop '() #f))
- ((fragment-frame? frame) ; add a fragment
- (loop (cons frame fragments) type))
- ((data-frame? frame) ; unfragmented data frame
- (handle-data-frame (frame-type frame) (frame-data frame))
- (loop '() #f)))))))
+ (define (serve-one-request request client-key)
+ (let ((response (make-handshake-response client-key)))
+ (write-response response client-socket)
+ (let loop ((fragments '())
+ (type #f))
+ (let ((frame (read-frame-maybe)))
+ (cond
+ ;; EOF - port is closed.
+ ((not frame)
+ (close-port client-socket))
+ ;; Per section 5.4, control frames may appear interspersed
+ ;; along with a fragmented message.
+ ((close-frame? frame)
+ ;; Per section 5.5.1, echo the close frame back to the
+ ;; client before closing the socket. The client may no
+ ;; longer be listening.
+ (false-if-exception
+ (write-frame (make-close-frame (frame-data frame)) client-socket))
+ (close-port client-socket))
+ ((ping-frame? frame)
+ ;; Per section 5.5.3, a pong frame must include the exact
+ ;; same data as the ping frame.
+ (write-frame (make-pong-frame (frame-data frame)) client-socket)
+ (loop fragments type))
+ ((pong-frame? frame) ; silently ignore pongs
+ (loop fragments type))
+ ((first-fragment-frame? frame) ; begin accumulating fragments
+ (loop (list frame) (frame-type frame)))
+ ((final-fragment-frame? frame) ; concatenate all fragments
+ (handle-data-frame type (frame-concatenate (reverse fragments)))
+ (loop '() #f))
+ ((fragment-frame? frame) ; add a fragment
+ (loop (cons frame fragments) type))
+ ((data-frame? frame) ; unfragmented data frame
+ (handle-data-frame (frame-type frame) (frame-data frame))
+ (loop '() #f)))))))
-(define* (run-server handler #:optional (server-socket (make-server-socket)))
+ (let* ((request (read-handshake-request client-socket))
+ (client-key (assoc-ref (request-headers request)
'sec-websocket-key)))
+ (if client-key
+ (serve-one-request request client-key)
+ (when fallback (fallback client-socket request)))))
+
+(define* (run-socket-server handler
+ #:optional (server-socket (make-server-socket))
+ (fallback (lambda (client-socket request) #f)))
"Run WebSocket server on SERVER-SOCKET. HANDLER, a procedure that
accepts a single argument, is called for each complete message that
the server receives from a client. When the message is in text
@@ -136,10 +143,11 @@ format, HANDLER is passed a string. When the message is
in binary
format, HANDLER is passed a bytevector. HANDLER must return either a
string, bytevector, or #f. Strings and bytevectors are sent to the
client in response to their message, and #f indicates that nothing
-should be sent back."
+should be sent back. Upon receiving a non-websocket request,
+FALLBACK is invoked."
;; TODO: Handle multiple simultaneous clients.
(listen server-socket 1)
(sigaction SIGPIPE SIG_IGN)
(let loop ()
- (serve-client (accept-new-client server-socket) handler)
+ (serve-client (accept-new-client server-socket) handler fallback)
(loop)))
--
2.9.2
--
Jan Nieuwenhuizen <address@hidden> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [PATCH] Allow websocket over http by adding fallback.,
Jan Nieuwenhuizen <=