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 <jann...@gnu.org> 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 <jann...@gnu.org> | GNU LilyPond http://lilypond.org Freelance IT http://JoyofSource.com | Avatar® http://AvatarAcademy.nl
