From ab7d0294d28fa686226e714a606c102e1f265a41 Mon Sep 17 00:00:00 2001 From: "Jan (janneke) Nieuwenhuizen" Date: Mon, 22 Apr 2019 19:03:37 +0200 Subject: [PATCH] websocket: Initial client actor support. * 8sync/systems/websocket/client.scm (no-op): New procedure. (): Change from record to actor and use it. (websocket-init): New method. (set-nonblocking!): New procedure. (make-client-socket): Use it. (make-websocket): Rename to... (websocket-open): ...this new method and change accordingly. (close-websocket): Rename to ... (websocket-close): ...this new method and change accordingly. (handshake, websocket-send, websocket-connecting, websocket-open?, websocket-closing?, websocket-closed?): Change to method and update accordingly. (display-websocket): Move to... (write)[): Call it for websocket upgrade, create new actor. * demos/websocket/8s-client.scm, demos/websocket/8s-server.scm, demos/websocket/ws-client.js, demos/websocket/ws-server.js: New files. * Makefile.am (EXTRA_DIST): Add them. --- 8sync/systems/websocket/client.scm | 289 +++++++++++++++++++---------- 8sync/systems/websocket/server.scm | 157 ++++------------ Makefile.am | 6 +- demos/websocket/8s-client.scm | 61 ++++++ demos/websocket/8s-server.scm | 76 ++++++++ demos/websocket/node-client.js | 26 +++ demos/websocket/ws-client.html | 43 +++++ demos/websocket/ws-client.js | 44 +++++ demos/websocket/ws-server.js | 48 +++++ 9 files changed, 536 insertions(+), 214 deletions(-) create mode 100755 demos/websocket/8s-client.scm create mode 100755 demos/websocket/8s-server.scm create mode 100644 demos/websocket/node-client.js create mode 100644 demos/websocket/ws-client.html create mode 100755 demos/websocket/ws-client.js create mode 100755 demos/websocket/ws-server.js diff --git a/8sync/systems/websocket/client.scm b/8sync/systems/websocket/client.scm index 86f82ef..11702f7 100644 --- a/8sync/systems/websocket/client.scm +++ b/8sync/systems/websocket/client.scm @@ -1,5 +1,7 @@ ;;; guile-websocket --- WebSocket client/server ;;; Copyright © 2016 David Thompson +;;; Copyright © 2017 Christopher Allan Webber +;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of guile-websocket. ;;; @@ -25,27 +27,161 @@ (define-module (8sync systems websocket client) #:use-module (ice-9 match) + #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) #:use-module (web request) #:use-module (web response) #:use-module (web uri) + #:use-module (oop goops) + #:use-module (8sync) + #:use-module (8sync ports) #:use-module (8sync contrib base64) #:use-module (8sync systems websocket frame) #:use-module (8sync systems websocket utils) - #:export (make-websocket - websocket? - websocket-uri - websocket-state + #:export ( + .on-close + .on-error + .on-message + .on-open + .socket + .state + .url + + websocket-closed? + websocket-closing? + websocket-connect websocket-connecting? websocket-open? - websocket-closing? - websocket-closed? - close-websocket - websocket-send - websocket-receive)) + + websocket-close + websocket-loop + websocket-send)) + +(define no-op (const #f)) + +(define-actor () + ((*init* websocket-init) + (close websocket-close) + (open websocket-open) + (send websocket-send)) + + (state #:accessor .state #:init-value 'closed #:init-keyword #:state) + (socket #:accessor .socket #:init-value #f #:init-keyword #:socket) + (url #:getter .url #:init-value #f #:init-keyword #:url) + (uri #:accessor .uri #:init-value #f #:init-keyword #:uri) + (entropy-port #:accessor .entropy-port #:init-form (open-entropy-port)) + + (on-close #:init-keyword #:on-close + #:init-value no-op + #:accessor .on-close) + (on-error #:init-keyword #:on-error + #:init-value no-op + #:accessor .on-error) + (on-message #:init-keyword #:on-message + #:accessor .on-message) + (on-open #:init-keyword #:on-open + #:init-value no-op + #:accessor .on-open)) + +(define-method (websocket-close (websocket ) message) + (when (websocket-open? websocket) + (false-if-exception (close-port (.socket websocket))) + (set! (.state websocket) 'closed) + (false-if-exception ((.on-close websocket) websocket)) + (set! (.socket websocket) #f))) + +(define-method (websocket-open (websocket ) message uri-or-string) + (if (websocket-closed? websocket) + (let ((uri (match uri-or-string + ((? uri? uri) uri) + ((? string? str) (string->uri str))))) + (if (websocket-uri? uri) + (catch 'system-error + (lambda _ + (set! (.uri websocket) uri) + (let ((sock (make-client-socket uri))) + (set! (.socket websocket) sock) + (handshake websocket) + (websocket-loop websocket message))) + (lambda (key . args) + ((.on-error websocket) websocket (format #f "open failed: ~s: ~s" uri-or-string args)))) + ((.on-error websocket) websocket (format #f "not a websocket uri: ~s" uri-or-string)))) + ((.on-error websocket) websocket (format #f "cannot open websocket in state: ~s" (.state websocket))))) + +(define-method (websocket-send (websocket ) message data) + (catch #t ; expect: wrong-type-arg (open port), system-error + (lambda _ + (write-frame + (cond ((string? data) + (make-text-frame data)) + ((bytevector? data) + (make-binary-frame data))) + (.socket websocket))) + (lambda (key . args) + (let ((message (format #f "~a: ~s" key args))) + ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message)) + (websocket-close websocket message))))) + +(define-method (websocket-init (websocket ) message) + (and=> (.url websocket) (cut websocket-open websocket message <>))) + +(define-method (websocket-loop (websocket ) message) + + (define (handle-data-frame type data) + ((.on-message websocket) + websocket + (match type + ('text (utf8->string data)) + ('binary data)))) + + (define (read-frame-maybe) + (and (not (eof-object? (lookahead-u8 (.socket websocket)))) + (read-frame (.socket websocket)))) + + (define (close-down) + (websocket-close websocket message)) + + ((.on-open websocket) websocket) + + (let loop ((fragments '()) + (type #f)) + (let* ((socket (.socket websocket)) + (frame (and (websocket-open? websocket) + (read-frame-maybe)))) + (cond + ;; EOF - port is closed. + ;; @@: Sometimes the eof object appears here as opposed to + ;; at lookahead, but I'm not sure why + ((or (not frame) (eof-object? frame)) + (close-down)) + ;; 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 + ;; socket before closing the socket. The socket may no + ;; longer be listening. + (false-if-exception + (write-frame (make-close-frame (frame-data frame)) socket)) + (close-down)) + ((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)) 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 (cons frame 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)))))) ;; See Section 3 - WebSocket URIs (define (encrypted-websocket-scheme? uri) @@ -64,6 +200,10 @@ scheme." (unencrypted-websocket-scheme? uri)) (not (uri-fragment uri)))) +(define (set-nonblocking! port) + (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL))) + (setvbuf port 'block 1024)) + (define (make-client-socket uri) "Connect a socket to the remote resource described by URI." (let* ((port (uri-port uri)) @@ -74,48 +214,43 @@ scheme." (if port AI_NUMERICSERV 0)))) - (s (with-fluids ((%default-port-encoding #f)) - (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP)))) - ;; TODO: Configure I/O buffering? - (connect s (addrinfo:addr info)) - s)) + (sock (with-fluids ((%default-port-encoding #f)) + (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP)))) -(define-record-type - (%make-websocket uri socket entropy-port state) - websocket? - (uri websocket-uri) - (socket websocket-socket) - (entropy-port websocket-entropy-port) - (state websocket-state set-websocket-state!)) + (set-nonblocking! sock) + ;; Disable buffering for websockets + (setvbuf sock 'none) -(define (display-websocket ws port) - (format port "#" - (uri->string (websocket-uri ws)) - (websocket-state ws))) + ;; TODO: Configure I/O buffering? + (connect sock (addrinfo:addr info)) + sock)) -(set-record-type-printer! display-websocket) +(define-method (write (o ) port) + (format port "#" + (.url o) + (.state o))) -(define (websocket-connecting? ws) - "Return #t if the WebSocket WS is in the connecting state." - (eq? (websocket-state ws) 'connecting)) +(define-method (websocket-connecting? (websocket )) + "Return #t if WEBSOCKET is in the connecting state." + (eq? (.state websocket) 'connecting)) -(define (websocket-open? ws) - "Return #t if the WebSocket WS is in the open state." - (eq? (websocket-state ws) 'open)) +(define-method (websocket-open? (websocket )) + "Return #t if WEBSOCKET is in the open state." + (eq? (.state websocket) 'open)) -(define (websocket-closing? ws) - "Return #t if the WebSocket WS is in the closing state." - (eq? (websocket-state ws) 'closing)) +(define-method (websocket-closing? (websocket )) + "Return #t if WEBSOCKET is in the closing state." + (eq? (.state websocket) 'closing)) -(define (websocket-closed? ws) - "Return #t if the WebSocket WS is in the closed state." - (eq? (websocket-state ws) 'closed)) +(define-method (websocket-closed? (websocket )) + "Return #t if WEBSOCKET is in the closed state." + (eq? (.state websocket) 'closed)) -(define (generate-client-key ws) +(define-method (generate-client-key (websocket )) "Return a random, base64 encoded nonce using the entropy source of -WS." +WEBSOCKET." (base64-encode - (get-bytevector-n (websocket-entropy-port ws) 16))) + (get-bytevector-n (.entropy-port websocket) 16))) ;; See Section 4.1 - Client Requirements (define (make-handshake-request uri key) @@ -129,12 +264,12 @@ KEY." (sec-websocket-version . "13")))) (build-request uri #:method 'GET #:headers headers))) -(define (handshake ws) - "Perform the WebSocket handshake for the client WS." - (let ((key (generate-client-key ws))) - (write-request (make-handshake-request (websocket-uri ws) key) - (websocket-socket ws)) - (let* ((response (read-response (websocket-socket ws))) +(define-method (handshake (websocket )) + "Perform the WebSocket handshake for the client WEBSOCKET." + (let ((key (generate-client-key websocket))) + (write-request (make-handshake-request (.uri websocket) key) + (.socket websocket)) + (let* ((response (read-response (.socket websocket))) (headers (response-headers response)) (upgrade (assoc-ref headers 'upgrade)) (connection (assoc-ref headers 'connection)) @@ -144,10 +279,12 @@ KEY." (string-ci=? (car upgrade) "websocket") (equal? connection '(upgrade)) (string=? (string-trim-both accept) (make-accept-key key))) - (set-websocket-state! ws 'open) + (set! (.state websocket) 'open) (begin - (close-websocket ws) - (error "websocket handshake failed" (websocket-uri ws))))))) + (websocket-close websocket) + ((.on-error websocket) websocket + (format #f "websocket handshake failed: ~s" + (uri->string (.uri websocket))))))))) (define (open-entropy-port) "Return an open input port to a reliable source of entropy for the @@ -156,25 +293,10 @@ current system." ;; exactly portable. (open-input-file "/dev/urandom")) -(define (make-websocket uri-or-string) - "Create and establish a new WebSocket connection for the remote -resource described by URI-OR-STRING." - (let ((uri (match uri-or-string - ((? uri? uri) uri) - ((? string? str) (string->uri str))))) - (if (websocket-uri? uri) - (let ((ws (%make-websocket uri - (make-client-socket uri) - (open-entropy-port) - 'connecting))) - (handshake ws) - ws) - (error "not a websocket uri" uri)))) - -(define (close-websocket ws) - "Close the WebSocket connection for the client WS." - (let ((socket (websocket-socket ws))) - (set-websocket-state! ws 'closing) +(define-method (websocket-close (websocket )) + "Close the WebSocket connection for the client WEBSOCKET." + (let ((socket (.socket websocket))) + (set! (.state websocket) 'closing) (write-frame (make-close-frame (make-bytevector 0)) socket) ;; Per section 5.5.1 , wait for the server to close the connection ;; for a reasonable amount of time. @@ -185,26 +307,5 @@ resource described by URI-OR-STRING." (read-frame socket) ; throw it away (loop))))) (close-port socket) - (close-port (websocket-entropy-port ws)) - (set-websocket-state! ws 'closed) - *unspecified*)) - -(define (generate-masking-key ws) - "Create a new masking key using the entropy source of WS." - ;; Masking keys are 32 bits long. - (get-bytevector-n (websocket-entropy-port ws) 4)) - -(define (websocket-send ws data) - "Send DATA, a string or bytevector, to the server that WS is -connected to." - ;; TODO: Send frames over some threshold in fragments. - (write-frame (make-text-frame data (generate-masking-key ws)) - (websocket-socket ws))) - -(define (websocket-receive ws) - "Read a response from the server that WS is connected to." - ;; TODO: Handle fragmented frames and control frames. - (let ((frame (read-frame (websocket-socket ws)))) - (if (binary-frame? frame) - (frame-data frame) - (text-frame->string frame)))) + (close-port (.entropy-port websocket)) + (set! (.state websocket) 'closed))) diff --git a/8sync/systems/websocket/server.scm b/8sync/systems/websocket/server.scm index c29ce51..2a91b92 100644 --- a/8sync/systems/websocket/server.scm +++ b/8sync/systems/websocket/server.scm @@ -1,7 +1,7 @@ ;;; guile-websocket --- WebSocket client/server ;;; Copyright © 2015 David Thompson ;;; Copyright © 2017 Christopher Allan Webber -;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of guile-websocket. ;;; @@ -36,17 +36,10 @@ #:use-module (8sync) #:use-module (8sync ports) #:use-module (8sync systems web) + #:use-module (8sync systems websocket client) #:use-module (8sync systems websocket frame) #:use-module (8sync systems websocket utils) - #:export ( - .websocket-handler)) - -;; See section 4.2 for explanation of the handshake. -(define (read-handshake-request client-socket) - "Read HTTP request from CLIENT-SOCKET that should contain the -headers required for a WebSocket handshake." - ;; See section 4.2.1. - (read-request client-socket)) + #:export ()) (define (make-handshake-response client-key) "Return an HTTP response object for upgrading to a WebSocket @@ -61,124 +54,50 @@ string." (define no-op (const #f)) -(define (make-simple-counter) - (let ((count 0)) - (lambda () - (set! count (1+ count)) - count))) - (define-actor () - ((ws-send websocket-server-send)) + () (upgrade-paths #:init-value `(("websocket" . - ,(wrap-apply websocket-client-loop))) + ,(wrap-apply make-websocket-actor))) #:allocation #:each-subclass #:accessor .upgrade-paths) - (gen-client-id #:init-thunk make-simple-counter) - - ;; active websocket connections - (ws-clients #:init-thunk make-hash-table - #:accessor .ws-clients) - - (on-ws-message #:init-keyword #:on-ws-message - #:getter .on-ws-message) - (on-ws-client-connect #:init-keyword #:on-ws-client-connect - #:init-value no-op - #:getter .on-ws-client-connect) - (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect - #:init-value no-op - #:getter .on-ws-client-disconnect)) - -(define (web-server-gen-client-id websocket-server) - ((slot-ref websocket-server 'gen-client-id))) - -(define (websocket-client-loop websocket-server client request body) - "Serve client connected via CLIENT by performing the HTTP -handshake and listening for control and data frames. HANDLER is -called for each complete message that is received." - ;; TODO: We'll also want to handle stuff like the sub-protocol. - (define (handle-data-frame type data) - ((.on-ws-message websocket-server) - websocket-server client-id - (match type - ('text (utf8->string data)) - ('binary data)))) - - (define (read-frame-maybe) - (and (not (eof-object? (lookahead-u8 client))) - (read-frame client))) - - ;; Allows other actors to send things to this specific client - ;; @@: We probably could just increment a counter... - (define client-id (web-server-gen-client-id websocket-server)) - - (define (close-down) - (close-port client) - (hash-remove! (.ws-clients websocket-server) client-id) - ((.on-ws-client-disconnect websocket-server) - websocket-server client-id)) - - (hash-set! (.ws-clients websocket-server) client-id client) + (on-ws-connection #:init-keyword #:on-ws-connection + #:init-value no-op + #:getter .on-ws-connection) + + (on-ws-close #:init-keyword #:on-ws-close + #:init-value no-op + #:getter .on-ws-close) + (on-ws-error #:init-keyword #:on-ws-error + #:init-value no-op + #:getter .on-ws-error) + (on-ws-message #:init-keyword #:on-ws-message + #:init-value no-op + #:getter .on-ws-message) + (on-ws-open #:init-keyword #:on-ws-open + #:init-value no-op + #:getter .on-ws-open)) + +(define (make-websocket-actor websocket-server client request body) + "Setup websocket actor connected via CLIENT by performing the HTTP +handshake." ;; Disable buffering for websockets (setvbuf client 'none) - ((.on-ws-client-connect websocket-server) - websocket-server client-id) - ;; Perform the HTTP handshake and upgrade to WebSocket protocol. (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key)) (response (make-handshake-response client-key))) - (write-response response client) - (let loop ((fragments '()) - (type #f)) - (let ((frame (read-frame-maybe))) - (cond - ;; EOF - port is closed. - ;; @@: Sometimes the eof object appears here as opposed to - ;; at lookahead, but I'm not sure why - ((or (not frame) (eof-object? frame)) - (close-down)) - ;; 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)) - (close-down)) - ((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) - (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 (cons frame 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 (websocket-server-send websocket-server message client-id data) - (cond ((hash-ref (.ws-clients websocket-server) client-id) => - (lambda (client) - (write-frame - (cond ((string? data) - (make-text-frame data)) - ((bytevector? data) - (make-binary-frame data))) - client) - ;; ok is like success, amirite - (<-reply message 'ok))) - (else - ;; No such client with that id. - ;; Either it closed, or it was never there. - (<-reply message 'client-gone)))) + (write-response response client)) + + (let* ((websocket-id (create-actor websocket-server + #:socket client + #:state 'open + #:on-close (.on-ws-close websocket-server) + #:on-error (.on-ws-error websocket-server) + #:on-message (.on-ws-message websocket-server) + #:on-open (.on-ws-open websocket-server))) + (hive ((@@ (8sync actors) actor-hive) websocket-server)) + (websocket ((@@ (8sync actors) hive-resolve-local-actor) hive websocket-id))) + ((.on-ws-connection websocket-server) websocket-id) + (websocket-loop websocket 'message))) diff --git a/Makefile.am b/Makefile.am index ea4061a..bc75d48 100644 --- a/Makefile.am +++ b/Makefile.am @@ -91,7 +91,11 @@ EXTRA_DIST = \ demos/ircbot.scm \ demos/actors/botherbotherbother.scm \ demos/actors/simplest-possible.scm \ - demos/actors/robotscanner.scm + demos/actors/robotscanner.scm \ + demos/websocket/8s-client.scm \ + demos/websocket/8s-server.scm \ + demos/websocket/ws-client.js \ + demos/websocket/ws-server.js ## Make changelog on demand diff --git a/demos/websocket/8s-client.scm b/demos/websocket/8s-client.scm new file mode 100755 index 0000000..09fe137 --- /dev/null +++ b/demos/websocket/8s-client.scm @@ -0,0 +1,61 @@ +#! /usr/bin/env guile +# -*-scheme-*- +!# + +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(define-module (8s-client) + #:use-module (oop goops) + #:use-module (8sync) + #:use-module (8sync systems websocket client) + + #:export (main)) + +(define %default-server "ws://localhost:1236") + +(define-actor () + ((*init* sleeper-loop)) + (sleep-secs #:init-value 3 #:getter sleeper-sleep-secs)) + +(define (sleeper-loop actor message) + (while (actor-alive? actor) + (display "Zzzzzzzz....\n") + ;; Sleep for a bit + (8sleep (sleeper-sleep-secs actor)))) + +(define (main . args) + (let* ((hive (make-hive)) + (sleeper (bootstrap-actor hive )) + (websocket-id (bootstrap-actor hive + #:url %default-server ;; toggle open with url/with message + #:on-close (lambda (ws) + (format (current-error-port) "on-close: ~s\n" ws)) + #:on-error (lambda (ws e) + (format (current-error-port) "on-error: ~s:~s\n" ws e)) + #:on-message (lambda (ws msg) + (format (current-error-port) "on-message: ~s:~s\n" ws msg)) + #:on-open (lambda (ws) + (format (current-error-port) "on-open: ~s\n" ws) + (websocket-send ws 'message "Hello, Web Socket!")))) + (websocket ((@@ (8sync actors) hive-resolve-local-actor) hive websocket-id))) + (if (.url websocket) + (run-hive hive '()) + (run-hive hive (list (bootstrap-message hive websocket-id 'open %default-server)))))) + +(main (command-line)) diff --git a/demos/websocket/8s-server.scm b/demos/websocket/8s-server.scm new file mode 100755 index 0000000..45e62ba --- /dev/null +++ b/demos/websocket/8s-server.scm @@ -0,0 +1,76 @@ +#! /usr/bin/env guile +# -*-scheme-*- +!# + +;;; 8sync --- Asynchronous programming for Guile +;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of 8sync. +;;; +;;; 8sync is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; 8sync is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with 8sync. If not, see . + +(define-module (8s-server) + #:use-module (oop goops) + #:use-module (8sync) + #:use-module (8sync systems web) + #:use-module (8sync systems websocket client) + #:use-module (8sync systems websocket server) + #:export (main)) + +(define %server-port 1236) + +(define-actor () + ((*init* sleeper-loop)) + (sleep-secs #:init-value 3 #:getter sleeper-sleep-secs)) + +(define (sleeper-loop actor message) + (while (actor-alive? actor) + (display "Zzzzzzzz....\n") + ;; Sleep for a bit + (8sleep (sleeper-sleep-secs actor)))) + +(define (main . args) + (let* ((hive (make-hive)) + (sleeper (bootstrap-actor hive )) + (server (bootstrap-actor + hive + #:port %server-port + #:on-ws-connection + (lambda (ws) + (format (current-error-port) "on-ws-connection: ws=~s\n" ws) + (when #f + (set! (.on-close ws) + (lambda (ws) + (format (current-error-port) "on-close: ~s\n" ws))) + (set! (.on-error ws) + (lambda (ws e) + (format (current-error-port) "on-error: ~s, ~s\n" ws e))) + (set! (.on-message ws) + (lambda (ws msg) + (format (current-error-port) "on-message: ~s\n" msg))) + (set! (.on-open ws) + (lambda (ws) + (format (current-error-port) "on-open: ~s\n" ws))))) + #:on-ws-close (lambda (ws) + (format (current-error-port) "on-close: ~s\n" ws)) + #:on-ws-error (lambda (ws e) + (format (current-error-port) "on-error: ~s: ~s\n" ws e)) + #:on-ws-message (lambda (ws msg) + (format (current-error-port) "on-message: ~s: ~s\n" ws msg)) + #:on-ws-open (lambda (ws) + (format (current-error-port) "on-open: ~s\n" ws))))) + (format (current-error-port) "listening: ~s\n" %server-port) + (run-hive hive '()))) + +(main (command-line)) diff --git a/demos/websocket/node-client.js b/demos/websocket/node-client.js new file mode 100644 index 0000000..401d3b7 --- /dev/null +++ b/demos/websocket/node-client.js @@ -0,0 +1,26 @@ +#! /usr/bin/env node + +var default_server = 'ws://localhost:1236'; + +// npm install -g ws +function main () { + var ws = new require ('ws') (default_server); + ws.onopen = function () { + console.log ('ws.onopen'); + process.nextTick (function () { + ws.send ('Hello Web Socket'); + }); + } + ws.onerror = function (e) { + console.log ('ws.onerror: e=%s', '' + e); + } + ws.onclose = function () { + console.log ('ws.onclose'); + } + ws.onmessage = function (event) { + var msg = event.data; + console.log ('ws.onmessage: ws=%j, msg=%s', msg); + }; +} + +main (); diff --git a/demos/websocket/ws-client.html b/demos/websocket/ws-client.html new file mode 100644 index 0000000..5e9c811 --- /dev/null +++ b/demos/websocket/ws-client.html @@ -0,0 +1,43 @@ + + + + + Ws test + + +

+ + + diff --git a/demos/websocket/ws-client.js b/demos/websocket/ws-client.js new file mode 100755 index 0000000..134fa01 --- /dev/null +++ b/demos/websocket/ws-client.js @@ -0,0 +1,44 @@ +#! /usr/bin/env node + +/// 8sync --- Asynchronous programming for Guile +/// Copyright © 2019 Jan (janneke) Nieuwenhuizen +/// +/// This file is part of 8sync. +/// +/// 8sync is free software: you can redistribute it and/or modify it +/// under the terms of the GNU Lesser General Public License as +/// published by the Free Software Foundation, either version 3 of the +/// License, or (at your option) any later version. +/// +/// 8sync is distributed in the hope that it will be useful, +/// but WITHOUT ANY WARRANTY; without even the implied warranty of +/// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +/// GNU Lesser General Public License for more details. +/// +/// You should have received a copy of the GNU Lesser General Public +/// License along with 8sync. If not, see . + +var default_server = 'ws://localhost:1236'; + +// npm install -g ws +function main () { + var ws = new require ('ws') (default_server); + ws.onopen = function () { + console.log ('ws.onopen'); + process.nextTick (function () { + ws.send ('Hello Web Socket'); + }); + } + ws.onerror = function (e) { + console.log ('ws.onerror: e=%s', '' + e); + } + ws.onclose = function () { + console.log ('ws.onclose'); + } + ws.onmessage = function (event) { + var msg = event.data; + console.log ('ws.onmessage: msg=%s', msg); + }; +} + +main (); diff --git a/demos/websocket/ws-server.js b/demos/websocket/ws-server.js new file mode 100755 index 0000000..47a4209 --- /dev/null +++ b/demos/websocket/ws-server.js @@ -0,0 +1,48 @@ +#! /usr/bin/env node + +/// 8sync --- Asynchronous programming for Guile +/// Copyright © 2019 Jan (janneke) Nieuwenhuizen +/// +/// This file is part of 8sync. +/// +/// 8sync is free software: you can redistribute it and/or modify it +/// under the terms of the GNU Lesser General Public License as +/// published by the Free Software Foundation, either version 3 of the +/// License, or (at your option) any later version. +/// +/// 8sync is distributed in the hope that it will be useful, +/// but WITHOUT ANY WARRANTY; without even the implied warranty of +/// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +/// GNU Lesser General Public License for more details. +/// +/// You should have received a copy of the GNU Lesser General Public +/// License along with 8sync. If not, see . + +var server_port = 1236; + +// npm install -g ws +function main () { + var wss = new require ('ws').Server ({port:server_port}); + console.log ('listening: %s', server_port); + wss.on ('connection', function (ws) { + ws.onopen = function () { + console.log ('ws.onopen'); + // process.nextTick (function () { + // ws.send ('Hello Web Socket'); + // ws.close (); + // }); + } + ws.onerror = function (e) { + console.log ('ws.onerror: e=%s', '' + e); + } + ws.onclose = function () { + console.log ('ws.onclose'); + } + ws.onmessage = function (event) { + var msg = event.data; + console.log ('ws.onmessage: msg=%s', msg); + }; + }); +} + +main (); -- 2.31.1