bug: suspendable put-bytevector.

To reproduce, do something like

   ./pre-inst-env demos/websocket/8s-server.scm&
   chromium demos/websocket/ws-client.html
or
   icecat demos/websocket/ws-client.html

and reload browser window several times.  The server should produce a
backtrace like

18:59:44 janneke@dundal:~/src/8sync/bug [env]
$ ./pre-inst-env demos/websocket/8s-server.scm
;;; note: source file /home/janneke/src/8sync/bug/demos/websocket/8s-server.scm
;;;       newer than compiled /home/janneke/.cache/guile/ccache/2.2-LE-8-3.A/home/janneke/src/8sync/bug/demos/websocket/8s-server.scm.go
;;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0
;;;       or pass the --no-auto-compile argument to disable.
;;; compiling /home/janneke/src/8sync/bug/demos/websocket/8s-server.scm
;;; compiled /home/janneke/.cache/guile/ccache/2.2-LE-8-3.A/home/janneke/src/8sync/bug/demos/websocket/8s-server.scm.go
listening: 1236
Zzzzzzzz....
on-ws-connection: args=(#<<websocket-server> 249ed80> 1)
on-ws-message: args= (("/home/janneke/src/8sync/bug/demos/websocket/8s-server.scm"))
on-message: ws: "Hello, Web Socket!"
on-ws-message: args= (("/home/janneke/src/8sync/bug/demos/websocket/8s-server.scm"))
on-message: ws: "Say: AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA..."
While reading request:
In procedure fport_read: Connection reset by peer

*** Caught exception with key 'system-error and arguments: ("fport_write" "~A" ("Broken pipe") (32)) ***
In ice-9/boot-9.scm:
    829:9 19 (catch #t #<procedure 2530ba0 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9 18 (catch #t #<procedure 2530da0 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9 17 (catch #t #<procedure 2530fa0 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9 16 (catch #t #<procedure 2517d60 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9 15 (catch #t #<procedure 2503640 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
In 8sync/actors.scm:
    596:6 14 (call-catching-coroutine #<procedure 2503600 at 8sync/actors.scm:611:7 ()> _)
    576:6 13 (call-catching-errors)
In ice-9/boot-9.scm:
    829:9 12 (catch #t #<procedure 2503600 at 8sync/actors.scm:611:7 ()> #<procedure 7f6432b8f958 at 8sync/ac…> …)
In 8sync/actors.scm:
   616:18 11 (_)
In ice-9/boot-9.scm:
    841:4 10 (with-throw-handler _ _ _)
In 8sync/systems/web.scm:
   167:10  9 (_ _ . _)
In web/response.scm:
    221:2  8 (write-response #<<response> version: (1 . 0) code: 400 reason-phrase: #f headers: ((content-len…> …)
In web/http.scm:
   1199:2  7 (write-response-line (1 . 0) 400 "Bad Request" #<closed: file 2702930>)
   1081:2  6 (write-http-version (1 . 0) #<closed: file 2702930>)
In ice-9/suspendable-ports.scm:
   662:12  5 (put-string #<closed: file 2702930> "HTTP/" _ _)
     83:4  4 (write-bytes #<closed: file 2702930> #vu8(72 84 84 80 47 54 76 101 106 51 78 104 110 122 74 116 …) …)
In unknown file:
           3 (port-write #<closed: file 2702930> #vu8(72 84 84 80 47 54 76 101 106 51 78 104 110 122 74 116 …) …)
In ice-9/boot-9.scm:
   752:25  2 (dispatch-exception _ _ _)
   751:25  1 (dispatch-exception 1 system-error ("fport_write" "~A" ("Broken pipe") (32)))
In 8sync/agenda.scm:
   597:23  0 (print-error-and-continue _ . _)

*** Caught exception with key 'wrong-type-arg and arguments: ("port-write" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "open output port" #<closed: file 2702930>) (#<closed: file 2702930>)) ***
In ice-9/eval.scm:
    619:8 19 (_ #(#(#<directory (guile-user) 23ef140>)))
In ice-9/boot-9.scm:
   2312:4 18 (save-module-excursion _)
  3822:12 17 (_)
In 8sync/actors.scm:
    812:6 16 (run-hive #<<hive> 28a6500> _ #:cleanup _ #:handle-signals _)
In ice-9/control.scm:
    91:24 15 (call-with-escape-continuation _)
In 8sync/agenda.scm:
    568:6 14 (run-agenda #<<agenda> queue: (() . #f) prompt-tag: ("prompt") read-port-map: #<hash-table 24f18…> …)
    631:5 13 (agenda-run-once! #<<agenda> queue: (() . #f) prompt-tag: ("prompt") read-port-map: #<hash-table …>)
In ice-9/boot-9.scm:
    829:9 12 (catch #t #<procedure 2c67d40 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9 11 (catch #t #<procedure 2ebbf20 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9 10 (catch #t #<procedure 2530120 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
    829:9  9 (catch #t #<procedure 25304e0 at 8sync/agenda.scm:638:11 ()> #<procedure 7f6432c26c30 at 8sync/a…> …)
In 8sync/actors.scm:
    596:6  8 (call-catching-coroutine #<procedure 25304a0 at 8sync/actors.scm:611:7 ()> _)
    576:6  7 (call-catching-errors)
In ice-9/boot-9.scm:
    829:9  6 (catch #t #<procedure 25304a0 at 8sync/actors.scm:611:7 ()> #<procedure 7f6432b8f958 at 8sync/ac…> …)
In 8sync/actors.scm:
   616:18  5 (_)
In 8sync/systems/websocket/server.scm:
   171:11  4 (websocket-server-send _ #<<message> id: "f89a760cec1b14c9c6654de548156342:8" to: #("<websocket-…> …)
In ice-9/suspendable-ports.scm:
     83:5  3 (write-bytes #<closed: file 2702930> #vu8(83 97 121 58 32 65 65 65 65 65 65 65 65 65 65 65 65 # …) …)
In unknown file:
           2 (port-write #<closed: file 2702930>)
In ice-9/boot-9.scm:
   751:25  1 (dispatch-exception 0 wrong-type-arg ("port-write" "Wrong type argument in position ~A (expect…" …))
In 8sync/agenda.scm:
   597:23  0 (print-error-and-continue _ . _)

Zzzzzzzz....
  C-c C-c

The problem does not occur when enabling these lines

  (define put-bytevector (@ (ice-9 binary-ports) put-bytevector))
  (module-define! (resolve-module '(8sync systems websocket frame)) 'put-bytevector put-bytevector)

in demos/websocket/8s-server.scm

* demos/websocket/ws-client.html: New file.
* demos/websocket/8s-server.scm: New file.

diff --git a/demos/websocket/8s-server.scm b/demos/websocket/8s-server.scm
new file mode 100755 (executable)
index 0000000..f271827
--- /dev/null
+++ b/demos/websocket/8s-server.scm
@@ -0,0 +1,73 @@
+#! /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>))
+         (suspendable-port-bug? #t) ;; server must send large message to browser
+         (server (bootstrap-actor
+                  hive <websocket-server>
+                  #:port %server-port
+                  #:on-ws-client-connect (lambda args
+                                           (format (current-error-port) "on-ws-client-connection: ~s\n" args))
+                  #:on-ws-client-disconnect (lambda args
+                                              (format (current-error-port) "on-ws-client-disconnect: ~s\n" args))
+                  #:on-ws-message (lambda (ws id msg)
+                                    (format (current-error-port) "on-message: ~s: ~s\n" 'ws
+                                            (if (< (string-length msg) 80) msg
+                                                (string-append (substring msg 0 77) "...")))
+                                    (<- (actor-id ws) 'ws-send id msg)
+                                    (when suspendable-port-bug?
+                                      (<- (actor-id ws) 'ws-send id (string-append "Say: " (make-string (expt 2 16) #\A) "\n"))))
+                  #: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 '())))
+
+;; HACK: Do not suspend writes to avoid
+;; `The connection to ws://localhost:1236/ was interrupted while the page was loading.' (icecat)
+;; `could not decode a text frame as utf-8' (ungoogled chromium)
+
+;; (define put-bytevector (@ (ice-9 binary-ports) put-bytevector))
+;; (module-define! (resolve-module '(8sync systems websocket frame)) 'put-bytevector put-bytevector)
+
+(main (command-line))

diff --git a/demos/websocket/ws-client.html b/demos/websocket/ws-client.html
new file mode 100644 (file)
index 0000000..5e9c811
--- /dev/null
+++ b/demos/websocket/ws-client.html
@@ -0,0 +1,43 @@
+<!--
+    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>