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          (server (bootstrap-actor
  47                   hive <websocket-server>
  48                   #:port %server-port
  49                   #:on-ws-connection
  50                   (lambda (ws)
  51                     (format (current-error-port) "on-ws-connection: ws=~s\n" ws)
  52                     (when #f
  53                       (set! (.on-close ws)
  54                            (lambda (ws)
  55                              (format (current-error-port) "on-close: ~s\n" ws)))
  56                       (set! (.on-error ws)
  57                             (lambda (ws e)
  58                               (format (current-error-port) "on-error: ~s, ~s\n" ws e)))
  59                       (set! (.on-message ws)
  60                             (lambda (ws msg)
  61                               (format (current-error-port) "on-message: ~s\n" msg)))
  62                       (set! (.on-open ws)
  63                             (lambda (ws)
  64                               (format (current-error-port) "on-open: ~s\n" ws)))))
  65                   #:on-ws-close (lambda (ws)
  66                                  (format (current-error-port) "on-close: ~s\n" ws))
  67                   #:on-ws-error (lambda (ws e)
  68                                   (format (current-error-port) "on-error: ~s: ~s\n" ws e))
  69                   #:on-ws-message (lambda (ws msg)
  70                                     (format (current-error-port) "on-message: ~s: ~s\n" ws msg))
  71                   #:on-ws-open (lambda (ws)
  72                                  (format (current-error-port) "on-open: ~s\n" ws)))))
  73     (format (current-error-port) "listening: ~s\n" %server-port)
  74     (run-hive hive '())))
  75
  76 (main (command-line))