mq-impl/stream: Implement connecting to unix sockets.

* README.org
  (Message queues): Note existence of 'connect-unix'.
  (List of errors): Mention 'connection:connected'.
* gnu/gnunet/mq-impl/stream.scm
  (%path-resolution-errors): New variable.
  (connect-unix): New procedure.
  (connect/fibers): New procedure.
* tests/mq-stream.scm
  (call-with-temporary-directory)
  (make-config)
  (call-with-socket-location)
  (connect/test)
  (alist->hash-table)
  (test-connection)
  (yield-many): New procedures.
  ("connect-unix, can connect when socket is already listening")
  ("connect-unix, will connect when socket is listening")
  ("connect-unix, will connect when socket is bound (and listening)")
  ("connect-unix, will connect even if there's an old socket lying
  around")
  ("connect-unix, will connect even if previous socket is different
  type")
  ("connect-unix, will connect even if permissions are temporarily
  wrong"): New tests.

1 files changed, 172 insertions, 1 deletions

diff --git a/tests/mq-stream.scm b/tests/mq-stream.scm
index fa70a1d..1fce3f5 100644
--- a/tests/mq-stream.scm
+++ b/tests/mq-stream.scm
@@ -21,6 +21,7 @@
              (gnu gnunet mq handler)
              (gnu gnunet utils hat-let)
              (gnu gnunet utils bv-slice)
+             (gnu gnunet config db)
              (gnu gnunet concurrency repeated-condition)
              (fibers conditions)
              (fibers operations)
@@ -28,12 +29,15 @@
              (rnrs bytevectors)
              ((rnrs io ports) #:select (open-bytevector-input-port))
              ((rnrs base) #:select (assert))
+             (rnrs hashtables)
              (srfi srfi-26)
              (srfi srfi-43)
              (rnrs io ports)
              (ice-9 binary-ports)
              (ice-9 suspendable-ports)
-             (ice-9 control))
+             (ice-9 control)
+             (ice-9 match)
+             (ice-9 threads))
 
 (define (no-sender . _)
   (error "no sender!"))
@@ -231,4 +235,171 @@
          #:parallelism 1
          #:hz 0)))
 
+(define (call-with-temporary-directory proc)
+  (let ((file (mkdtemp (in-vicinity (or (getenv "TMPDIR") "/tmp")
+                                    "test-XXXXXX"))))
+    (with-exception-handler
+        (lambda (e)
+          (system* "rm" "-r" file)
+          (raise-exception e))
+      (lambda ()
+        (call-with-values
+            (lambda () (proc file))
+          (lambda the-values
+            (system* "rm" "-r" file)
+            (apply values the-values)))))))
+
+(define (make-config where)
+  (hash->configuration
+   (alist->hash-table
+    `((("service" . "UNIXPATH") . ,where)))))
+
+(define (call-with-socket-location proc)
+  (call-with-temporary-directory
+   (lambda (dir)
+     (define where (in-vicinity dir "sock.et"))
+     (define config  (make-config where))
+     (proc where config))))
+
+(define (connect/test config connected?)
+  (define (error-handler . error)
+    (match error
+      ;; XXX correct documentation: multiple end-of-files
+      ;; are perfectly possible.
+      (('input:regular-end-of-file) (values))
+      (('connection:connected) (signal-condition! connected?))))
+  (connect/fibers config "service" no-handlers error-handler
+                  #:spawn call-with-new-thread))
+
+(define (alist->hash-table alist)
+  (define h (make-hashtable (lambda (key) 0) equal?))
+  (define (insert! key+value)
+    (hashtable-set! h (car key+value) (cdr key+value)))
+  (for-each insert! alist)
+  h)
+
+(define (test-connection mq server-sock)
+  (send-message! mq (bv-slice/read-write #vu8(0 4 0 0)))
+  (let ((client (car (accept server-sock))))
+    (assert (equal? #vu8(0 4 0 0) (get-bytevector-n client 4)))
+    #t))
+
+(define (yield-many)
+  ;; Give the new threads some time to run before binding the socket.
+  ;; This allowed a bug in the use of 'connect' to be detected.
+  (let loop ((n (* 8 (+ 1 (length (all-threads))))))
+    (when (> n 0)
+      (yield)
+      (loop (- n 1)))))
+
+(test-assert "connect-unix, can connect when socket is already listening"
+  (call-with-socket-location
+   (lambda (where config)
+     (define listening-sock (socket PF_UNIX SOCK_STREAM 0))
+     (define connected? (make-condition))
+     (bind listening-sock AF_UNIX where)
+     (listen listening-sock 1)
+     (define mq (connect/test config connected?))
+     (wait connected?)
+     (test-connection mq listening-sock))))
+
+;; Consider the case where a service starts, has bound its socket
+;; but is not yet listening, and a client connects.
+(test-assert "connect-unix, will connect when socket is listening"
+  (call-with-socket-location
+   (lambda (where config)
+     (define listening-sock (socket PF_UNIX SOCK_STREAM 0))
+     (define connected? (make-condition))
+     (bind listening-sock AF_UNIX where)
+     (define mq (connect/test config connected?))
+     (yield-many)
+     (listen listening-sock 1)
+     (wait connected?)
+     (test-connection mq listening-sock))))
+
+;; Consider the case where a client starts before a service.
+(test-assert "connect-unix, will connect when socket is bound (and listening)"
+  (call-with-socket-location
+   (lambda (where config)
+     (define listening-sock (socket PF_UNIX SOCK_STREAM 0))
+     (define connected? (make-condition))
+     (define mq (connect/test config connected?))
+     (yield-many)
+     (bind listening-sock AF_UNIX where)
+     (listen listening-sock 1)
+     (wait connected?)
+     (test-connection mq listening-sock))))
+
+;; Consider the case where a service starts and stops,
+;; a client connects and the service restarts.
+(test-assert
+    "connect-unix, will connect even if there's an old socket lying around"
+  (call-with-socket-location
+   (lambda (where config)
+     (let ((old-sock (socket PF_UNIX SOCK_STREAM 0)))
+       (bind old-sock AF_UNIX where)
+       (close-port old-sock))
+     (define connected? (make-condition))
+     (define mq (connect/test config connected?))
+     (yield-many)
+     (define listening-sock (socket PF_UNIX SOCK_STREAM 0))
+     (yield-many)
+     ;; Delete the old socket, otherwise the 'bind' below results in ‘address alreay in use’
+     (delete-file where)
+     (yield-many)
+     (bind listening-sock AF_UNIX where)
+     (yield-many)
+     (listen listening-sock 1)
+     (wait connected?)
+     (test-connection mq listening-sock))))
+
+;; Consider the case where GNUnet version N uses stream sockets,
+;; GNUnet version M uses datagram sockets, the system initially
+;; uses GNUnet version N, a client for version M is started
+;; (initially failing to connect to the server), then the system
+;; switches to GNUnet version M.
+(test-assert
+    "connect-unix, will connect even if previous socket is different type"
+  (call-with-socket-location
+   (lambda (where config)
+     (define old-sock (socket PF_UNIX SOCK_DGRAM 0))
+     (bind old-sock AF_UNIX where)
+     ;; Datagram sockets don't support 'listen', so don't
+     ;; call 'listen' with 'old-sock'.
+     (define connected? (make-condition))
+     (define mq (connect/test config connected?))
+     (yield-many)
+     (close-port old-sock)
+     (delete-file where)
+     (define new-sock (socket PF_UNIX SOCK_STREAM 0))
+     (bind new-sock AF_UNIX where)
+     (listen new-sock 1)
+     (wait connected?)
+     (test-connection mq new-sock))))
+
+;; Consider a system that creates directories and the socket
+;; with world-unreadable, world-unexecutable permissions at
+;; first and makes the permissions more permissive later.
+(test-assert
+    "connect-unix, will connect even if permissions are temporarily wrong"
+  (call-with-temporary-directory
+   (lambda (tmpdir)
+     ;; Permissions on sockets can be unreliable on some systems,
+     ;; so modify the permissions of a directory instead.
+     (define subdir (in-vicinity tmpdir "dir"))
+     (mkdir subdir)
+     (define where (in-vicinity subdir "sock.et"))
+     (define listening-sock (socket PF_UNIX SOCK_STREAM 0))
+     (bind listening-sock AF_UNIX where)
+     (listen listening-sock 1)
+     (chmod subdir #o000) ; unreadable
+     (define connected? (make-condition))
+     (define mq (connect/test (make-config where) connected?))
+     (yield-many)
+     ;; make it readable again
+     ;; (and writable such that 'tmpdir' can be deleted).
+     (chmod subdir #o700)
+     (wait connected?)
+     (test-connection mq listening-sock))))
+
 (test-end "mq-stream")