* 8sync/systems/websocket/client.scm (no-op): New procedure.
(<websocket>): 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)[<websocket]: ...this new specialization.
(set-record-type-printer!): Remove.
(websocket-loop): Renamed from...
* 8sync/systems/websocket/server.scm (websocket-client-loop): ...here.
(make-websocket-actor): New procedure.
(<websocket-server>): Call it for websocket upgrade, create new
<websocket> 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.
;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2016 David Thompson <davet@gnu.org>
+;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of guile-websocket.
;;;
(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 (<websocket>
+ .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 <websocket> (<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 <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 <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 <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)
+ (unless (and (memq key '(system-error wrong-type-arg))
+ (match args
+ (((or "put-u8" "put-bytevector") arg ...) #t)
+ (_ #f)))
+ (apply throw 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 <websocket>) message)
+ (and=> (.url websocket) (cut websocket-open websocket message <>)))
+
+(define-method (websocket-loop (websocket <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)
(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))
(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 <websocket>
- (%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 "#<websocket ~a ~a>"
- (uri->string (websocket-uri ws))
- (websocket-state ws)))
+ ;; TODO: Configure I/O buffering?
+ (connect sock (addrinfo:addr info))
+ sock))
-(set-record-type-printer! <websocket> display-websocket)
+(define-method (write (o <websocket>) port)
+ (format port "#<websocket ~a ~a>"
+ (.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 <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 <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 <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 <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 <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)
(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 <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))
(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
;; 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 <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.
(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)))
;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
-;;; Copyright © 2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2019,2020,2021 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of guile-websocket.
;;;
#: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-server>
- .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 (<websocket-server>))
(define (make-handshake-response client-key)
"Return an HTTP response object for upgrading to a WebSocket
(define no-op (const #f))
-(define (make-simple-counter)
- (let ((count 0))
- (lambda ()
- (set! count (1+ count))
- count)))
-
(define-actor <websocket-server> (<web-server>)
- ((ws-send websocket-server-send))
+ ()
(upgrade-paths #:init-value `(("websocket" .
- ,(wrap-apply websocket-client-loop)))
+ ,(wrap-apply make-websocket-actor)))
#:allocation #:each-subclass)
- (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 <websocket>
+ #: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)))
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
--- /dev/null
+#! /usr/bin/env guile
+# -*-scheme-*-
+!#
+
+;;; 8sync --- Asynchronous programming for Guile
+;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <sleeper> (<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 <sleeper>))
+ (websocket-id (bootstrap-actor hive <websocket>
+ #: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))
--- /dev/null
+#! /usr/bin/env guile
+# -*-scheme-*-
+!#
+
+;;; 8sync --- Asynchronous programming for Guile
+;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <sleeper> (<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 <sleeper>))
+ (server (bootstrap-actor
+ hive <websocket-server>
+ #: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))
--- /dev/null
+#! /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 ();
--- /dev/null
+<!--
+ 8sync --- Asynchronous programming for Guile
+ Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+
+ 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 <http://www.gnu.org/licenses/>.
+!-->
+<meta charset="utf8">
+<html>
+ <head>
+ <title>Ws test</title>
+ </head>
+ <body>
+ <p id="log"></p>
+ <script>
+ var server = "ws://localhost:1236";
+ var log = document.getElementById ("log");
+ console.log ('log=%j', log);
+ console.log ('document=%j', document);
+ console.log ('body=%j', document.body);
+ var ws = new WebSocket (server);
+ ws.onopen = function () {
+ console.log ('open!'); log.innerHTML += 'open!<br>';
+ ws.send ('Hello, Web Socket!');
+ ws.send ('Say: ' + 'A'.repeat (Math.pow (2, 16)) + '\n');
+ };
+ ws.close = function () { console.log ('close!'); log.innerHTML += 'close!<br>'; };
+ ws.onmessage = function () { console.log ('message'); log.innerHTML += 'message!<br>'; };
+ </script>
+ </body>
+</html>
--- /dev/null
+#! /usr/bin/env node
+
+/// 8sync --- Asynchronous programming for Guile
+/// Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+///
+/// 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 <http://www.gnu.org/licenses/>.
+
+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 ();
--- /dev/null
+#! /usr/bin/env node
+
+/// 8sync --- Asynchronous programming for Guile
+/// Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+///
+/// 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 <http://www.gnu.org/licenses/>.
+
+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 ();
projects / 8sync.git / commitdiff