Add ping client and server

* examples/ping-client.scm:
* examples/ping-server.scm: New files.

2 files changed, 157 insertions, 0 deletions

diff --git a/examples/ping-client.scm b/examples/ping-client.scm
new file mode 100644
index 0000000..60e5738
--- /dev/null
+++ b/examples/ping-client.scm
@@ -0,0 +1,79 @@
+;;; Simple ping client implementation
+
+;; Copyright (C)  2012 Free Software Foundation, Inc.
+
+;; This library 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.
+;;
+;; This library 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 this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+(use-modules (rnrs bytevectors)
+             (fibers)
+             (ice-9 binary-ports)
+             (ice-9 textual-ports)
+             (ice-9 rdelim)
+             (ice-9 match))
+
+(define (set-nonblocking! port)
+  (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
+  (setvbuf port 'block 1024))
+
+(define (server-error port msg . args)
+  (apply format (current-error-port) msg args)
+  (newline (current-error-port))
+  (close-port port)
+  (suspend))
+
+(define (connect-to-server addrinfo)
+  (let ((port (socket (addrinfo:fam addrinfo)
+                      (addrinfo:socktype addrinfo)
+                      (addrinfo:protocol addrinfo))))
+    ;; Disable Nagle's algorithm.  We buffer ourselves.
+    (setsockopt port IPPROTO_TCP TCP_NODELAY 0)
+    (set-nonblocking! port)
+    (connect port (addrinfo:addr addrinfo))
+    port))
+
+(define *active-clients* 0)
+
+(define (client-loop addrinfo n num-connections)
+  (set! *active-clients* (1+ *active-clients*))
+  (let ((port (connect-to-server addrinfo))
+        (test (string-append "test-" (number->string n))))
+    (let lp ((m 0))
+      (when (< m num-connections)
+        (put-string port test)
+        (put-char port #\newline)
+        (force-output port)
+        (let ((response (read-line port)))
+          (unless (equal? test response)
+            (server-error port "Bad response: ~A (expected ~A)" response test))
+          (lp (1+ m)))))
+    (close-port port))
+  (set! *active-clients* (1- *active-clients*))
+  (when (zero? *active-clients*)
+    (exit 0)))
+
+(define (run-ping-test num-clients num-connections)
+  ;; The getaddrinfo call blocks, unfortunately.  Call it once before
+  ;; spawning clients.
+  (let ((addrinfo (car (getaddrinfo "localhost" (number->string 11211)))))
+    (let lp ((n 0))
+      (when (< n num-clients)
+        (spawn
+         (lambda ()
+           (client-loop addrinfo n num-connections)))
+        (lp (1+ n)))))
+  (run))
+
+(apply run-ping-test (map string->number (cdr (program-arguments))))
diff --git a/examples/ping-server.scm b/examples/ping-server.scm
new file mode 100644
index 0000000..42f58af
--- /dev/null
+++ b/examples/ping-server.scm
@@ -0,0 +1,78 @@
+;;; Simple ping server implementation
+
+;; Copyright (C)  2016 Free Software Foundation, Inc.
+
+;; This library 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.
+;;
+;; This library 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 this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+(use-modules (rnrs bytevectors)
+             (fibers)
+             (ice-9 binary-ports)
+             (ice-9 textual-ports)
+             (ice-9 rdelim)
+             (ice-9 match))
+
+(define (set-nonblocking! port)
+  (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
+  (setvbuf port 'block 1024))
+
+(define (make-default-socket family addr port)
+  (let ((sock (socket PF_INET SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (fcntl sock F_SETFD FD_CLOEXEC)
+    (bind sock family addr port)
+    (set-nonblocking! sock)
+    sock))
+
+(define (client-loop port addr store)
+  (let loop ()
+    ;; TODO: Restrict read-line to 512 chars.
+    (let ((line (read-line port)))
+      (cond
+       ((eof-object? line)
+        (close-port port))
+       (else
+        (put-string port line)
+        (put-char port #\newline)
+        (force-output port)
+        (loop))))))
+
+;; todo: accept and connect
+(define (socket-loop socket store)
+  (let loop ()
+    (match (accept socket)
+      ((client . addr)
+       (set-nonblocking! client)
+       ;; Disable Nagle's algorithm.  We buffer ourselves.
+       (setsockopt client IPPROTO_TCP TCP_NODELAY 0)
+       (spawn (lambda () (client-loop client addr store)))
+       (loop)))))
+
+(define* (run-ping-server #:key
+                          (host #f)
+                          (family AF_INET)
+                          (addr (if host
+                                    (inet-pton family host)
+                                    INADDR_LOOPBACK))
+                          (port 11211)
+                          (socket (make-default-socket family addr port)))
+  (listen socket 1024)
+  (sigaction SIGPIPE SIG_IGN)
+  (spawn
+   (lambda ()
+     (socket-loop socket (make-hash-table))))
+  (run))
+
+(run-ping-server)