03/03: publish: Add '--listen'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 9e2292ef3d9e2626381f9726c72d71057160b7c3
Author: Ludovic Courtès <address@hidden>
Date:   Tue May 12 21:20:19 2015 +0200

    publish: Add '--listen'.
    
    * guix/scripts/publish.scm (show-help, %options): Add --listen.
      (getaddrinfo*): New procedure.
      (%default-options): Add 'address'.
      (open-server-socket): Replace 'addr' and 'port' with 'address', a
      sockaddr.
      (guix-publish): Adjust accordingly.  Augment "publishing" message with
      the actual address.
    * doc/guix.texi (Invoking guix publish): Document it.
---
 doc/guix.texi            |    4 +++
 guix/scripts/publish.scm |   58 ++++++++++++++++++++++++++++++++++------------
 2 files changed, 47 insertions(+), 15 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 8654e08..50d51c6 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3687,6 +3687,10 @@ The following options are available:
 @itemx -p @var{port}
 Listen for HTTP requests on @var{port}.
 
address@hidden address@hidden
+Listen on the network interface for @var{host}.  The default is to
+accept connections from any interface.
+
 @item address@hidden
 @itemx -u @var{user}
 Change privileges to @var{user} as soon as possible---i.e., once the
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 86d3a75..7bad261 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -51,6 +51,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (_ "
   -p, --port=PORT        listen on PORT"))
   (display (_ "
+      --listen=HOST      listen on the network interface for HOST"))
+  (display (_ "
   -u, --user=USER        change privileges to USER as soon as possible"))
   (display (_ "
   -r, --repl[=PORT]      spawn REPL server on PORT"))
@@ -62,6 +64,15 @@ Publish ~a over HTTP.\n") %store-directory)
   (newline)
   (show-bug-report-information))
 
+(define (getaddrinfo* host)
+  "Like 'getaddrinfo', but properly report errors."
+  (catch 'getaddrinfo-error
+    (lambda ()
+      (getaddrinfo host))
+    (lambda (key error)
+      (leave (_ "lookup of host '~a' failed: ~a~%")
+             host (gai-strerror error)))))
+
 (define %options
   (list (option '(#\h "help") #f #f
                 (lambda _
@@ -76,6 +87,15 @@ Publish ~a over HTTP.\n") %store-directory)
         (option '(#\p "port") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'port (string->number* arg) result)))
+        (option '("listen") #t #f
+                (lambda (opt name arg result)
+                  (match (getaddrinfo* arg)
+                    ((info _ ...)
+                     (alist-cons 'address (addrinfo:addr info)
+                                 result))
+                    (()
+                     (leave (_ "lookup of host '~a' returned nothing")
+                            name)))))
         (option '(#\r "repl") #f #t
                 (lambda (opt name arg result)
                   ;; If port unspecified, use default Guile REPL port.
@@ -83,7 +103,8 @@ Publish ~a over HTTP.\n") %store-directory)
                     (alist-cons 'repl (or port 37146) result))))))
 
 (define %default-options
-  '((port . 8080)
+  `((port . 8080)
+    (address . ,(make-socket-address AF_INET INADDR_ANY 0))
     (repl . #f)))
 
 (define (lazy-read-file-sexp file)
@@ -230,11 +251,11 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
               'http
               `(#:socket ,socket)))
 
-(define (open-server-socket addr port)
-  "Return a TCP socket bound to ADDR and PORT."
-  (let ((sock (socket PF_INET SOCK_STREAM 0)))
+(define (open-server-socket address)
+  "Return a TCP socket bound to ADDRESS, a socket address."
+  (let ((sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
     (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-    (bind sock AF_INET addr port)
+    (bind sock address)
     sock))
 
 (define (gather-user-privileges user)
@@ -256,15 +277,19 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
 
 (define (guix-publish . args)
   (with-error-handling
-    (let* ((opts   (args-fold* args %options
-                               (lambda (opt name arg result)
-                                 (leave (_ "~A: unrecognized option~%") name))
-                               (lambda (arg result)
-                                 (leave (_ "~A: extraneuous argument~%") arg))
-                               %default-options))
-           (port   (assoc-ref opts 'port))
-           (user   (assoc-ref opts 'user))
-           (socket (open-server-socket INADDR_ANY port))
+    (let* ((opts    (args-fold* args %options
+                                (lambda (opt name arg result)
+                                  (leave (_ "~A: unrecognized option~%") name))
+                                (lambda (arg result)
+                                  (leave (_ "~A: extraneuous argument~%") arg))
+                                %default-options))
+           (user    (assoc-ref opts 'user))
+           (port    (assoc-ref opts 'port))
+           (address (let ((addr (assoc-ref opts 'address)))
+                      (make-socket-address (sockaddr:fam addr)
+                                           (sockaddr:addr addr)
+                                           port)))
+           (socket  (open-server-socket address))
            (repl-port (assoc-ref opts 'repl)))
       ;; Read the key right away so that (1) we fail early on if we can't
       ;; access them, and (2) we can then drop privileges.
@@ -279,7 +304,10 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
       (when (zero? (getuid))
         (warning (_ "server running as root; \
 consider using the '--user' option!~%")))
-      (format #t (_ "publishing ~a on port ~d~%") %store-directory port)
+      (format #t (_ "publishing ~a on ~a, port ~d~%")
+              %store-directory
+              (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
+              (sockaddr:port address))
       (when repl-port
         (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
       (with-store store