demos/websocket/8s-server.scm

   1 #! /usr/bin/env guile
   2 # -*-scheme-*-
   3 !#
   4
   5 ;;; 8sync --- Asynchronous programming for Guile
   6 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   7 ;;;
   8 ;;; This file is part of 8sync.
   9 ;;;
  10 ;;; 8sync is free software: you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU Lesser General Public License as
  12 ;;; published by the Free Software Foundation, either version 3 of the
  13 ;;; License, or (at your option) any later version.
  14 ;;;
  15 ;;; 8sync is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU Lesser General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU Lesser General Public
  21 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (8s-server)
  24   #:use-module (oop goops)
  25   #:use-module (8sync)
  26   #:use-module (8sync systems web)
  27   #:use-module (8sync systems websocket client)
  28   #:use-module (8sync systems websocket server)
  29   #:export (main))
  30
  31 (define %server-port 1236)
  32
  33 (define-actor <sleeper> (<actor>)
  34   ((*init* sleeper-loop))
  35   (sleep-secs #:init-value 3 #:getter sleeper-sleep-secs))
  36
  37 (define (sleeper-loop actor message)
  38   (while (actor-alive? actor)
  39     (display "Zzzzzzzz....\n")
  40     ;; Sleep for a bit
  41     (8sleep (sleeper-sleep-secs actor))))
  42
  43 (define (main . args)
  44   (let* ((hive (make-hive))
  45          (sleeper (bootstrap-actor hive <sleeper>))
  46          (suspendable-port-bug? #t) ;; server must send large message to browser
  47          (server (bootstrap-actor
  48                   hive <websocket-server>
  49                   #:port %server-port
  50                   #:on-ws-client-connect (lambda args
  51                                            (format (current-error-port) "on-ws-client-connection: ~s\n" args))
  52                   #:on-ws-client-disconnect (lambda args
  53                                               (format (current-error-port) "on-ws-client-disconnect: ~s\n" args))
  54                   #:on-ws-message (lambda (ws id msg)
  55                                     (format (current-error-port) "on-message: ~s: ~s\n" 'ws
  56                                             (if (< (string-length msg) 80) msg
  57                                                 (string-append (substring msg 0 77) "...")))
  58                                     (<- (actor-id ws) 'ws-send id msg)
  59                                     (when suspendable-port-bug?
  60                                       (<- (actor-id ws) 'ws-send id (string-append "Say: " (make-string (expt 2 16) #\A) "\n"))))
  61                   #:on-ws-open (lambda (ws)
  62                                  (format (current-error-port) "on-open: ~s\n" ws)))))
  63     (format (current-error-port) "listening: ~s\n" %server-port)
  64     (run-hive hive '())))
  65
  66 ;; HACK: Do not suspend writes to avoid
  67 ;; `The connection to ws://localhost:1236/ was interrupted while the page was loading.' (icecat)
  68 ;; `could not decode a text frame as utf-8' (ungoogled chromium)
  69
  70 ;; (define put-bytevector (@ (ice-9 binary-ports) put-bytevector))
  71 ;; (module-define! (resolve-module '(8sync systems websocket frame)) 'put-bytevector put-bytevector)
  72
  73 (main (command-line))