From 276e494b2a1fd87874d80e2bdc3aa1fb833b76f2 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Sun, 22 Nov 2020 15:15:17 +0100
Subject: [PATCH] publish: Add advertising support.

* guix/scripts/publish.scm (%options): Add "--advertise" option.
(show-help): Document it.
(service-name): New procedure,
(publish-service-type): new variable.
(run-publish-server): Add "advertise?" and "port" parameters. Use them to publish
the server using Avahi.
(guix-publish): Pass the "advertise?" option to "run-publish-server".
* gnu/services/base.scm (<guix-publish-configuration>): Add "advertise?"
field.
(guix-publish-shepherd-service): Honor it.
---
 doc/guix.texi            |  5 +++++
 gnu/services/base.scm    |  8 +++++++-
 guix/scripts/publish.scm | 34 +++++++++++++++++++++++++++++++---
 3 files changed, 43 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index baf6e69039..8ca243004a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12159,6 +12159,11 @@ The signing key pair must be generated before @command{guix publish} is
 launched, using @command{guix archive --generate-key} (@pxref{Invoking
 guix archive}).
 
+When the @option{--advertise} option is passed, the server advertises
+its availability on the local network using multicast DNS (mDNS) and DNS
+service discovery (DNS-SD), currently @i{via} Guile-Avahi (@pxref{Top,,,
+guile-avahi, Using Avahi in Guile Scheme Programs}).
+
 The general syntax is:
 
 @example
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 3fc4d5f885..e3b347293e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1744,6 +1744,8 @@ proxy of 'guix-daemon'...~%")
            (default 80))
   (host    guix-publish-configuration-host        ;string
            (default "localhost"))
+  (advertise? guix-publish-advertise?       ;boolean
+              (default #f))
   (compression       guix-publish-configuration-compression
                      (thunked)
                      (default (default-compression this-record
@@ -1790,7 +1792,8 @@ raise a deprecation warning if the 'compression-level' field was used."
                    lst))))
 
   (match-record config <guix-publish-configuration>
-    (guix port host nar-path cache workers ttl cache-bypass-threshold)
+    (guix port host nar-path cache workers ttl cache-bypass-threshold
+          advertise?)
     (list (shepherd-service
            (provision '(guix-publish))
            (requirement '(guix-daemon))
@@ -1801,6 +1804,9 @@ raise a deprecation warning if the 'compression-level' field was used."
                            #$@(config->compression-options config)
                            (string-append "--nar-path=" #$nar-path)
                            (string-append "--listen=" #$host)
+                           #$@(if advertise?
+                                  #~("--advertise")
+                                  #~())
                            #$@(if workers
                                   #~((string-append "--workers="
                                                     #$(number->string
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 2a2185e2b9..4822ea55c0 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -42,6 +42,7 @@
   #:use-module (web server)
   #:use-module (web uri)
   #:autoload   (sxml simple) (sxml->xml)
+  #:use-module (guix avahi)
   #:use-module (guix base32)
   #:use-module (guix base64)
   #:use-module (guix config)
@@ -70,6 +71,7 @@
             signed-string
 
             open-server-socket
+            publish-service-type
             run-publish-server
             guix-publish))
 
@@ -83,6 +85,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (display (G_ "
   -u, --user=USER        change privileges to USER as soon as possible"))
   (display (G_ "
+  -a, --advertise        advertise on the local network"))
+  (display (G_ "
   -C, --compression[=METHOD:LEVEL]
                          compress archives with METHOD at LEVEL"))
   (display (G_ "
@@ -157,6 +161,9 @@ usage."
         (option '(#\V "version") #f #f
                 (lambda _
                   (show-version-and-exit "guix publish")))
+        (option '(#\a "advertise") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'advertise? #t result)))
         (option '(#\u "user") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'user arg result)))
@@ -1069,11 +1076,29 @@ methods, return the applicable compression."
           (x (not-found request)))
         (not-found request))))
 
+(define (service-name)
+  "Return the Avahi service name of the server."
+  (string-append "guix-publish-" (gethostname)))
+
+(define publish-service-type
+  ;; Return the Avahi service type of the server.
+  "_guix_publish._tcp")
+
 (define* (run-publish-server socket store
                              #:key
+                             advertise? port
                              (compressions (list %no-compression))
                              (nar-path "nar") narinfo-ttl
                              cache pool)
+  (when advertise?
+    (let ((name (service-name)))
+      ;; XXX: Use a callback from Guile-Avahi here, as Avahi can pick a
+      ;; different name to avoid name clashes.
+      (info (G_ "Advertising ~a~%.") name)
+      (avahi-publish-service-thread name
+                                    #:type publish-service-type
+                                    #:port port)))
+
   (run-server (make-request-handler store
                                     #:cache cache
                                     #:pool pool
@@ -1119,9 +1144,10 @@ methods, return the applicable compression."
                                 (lambda (arg result)
                                   (leave (G_ "~A: extraneous argument~%") arg))
                                 %default-options))
-           (user    (assoc-ref opts 'user))
-           (port    (assoc-ref opts 'port))
-           (ttl     (assoc-ref opts 'narinfo-ttl))
+           (advertise?  (assoc-ref opts 'advertise?))
+           (user        (assoc-ref opts 'user))
+           (port        (assoc-ref opts 'port))
+           (ttl         (assoc-ref opts 'narinfo-ttl))
            (compressions (match (filter-map (match-lambda
                                               (('compression . compression)
                                                compression)
@@ -1179,6 +1205,8 @@ consider using the '--user' option!~%")))
 
         (with-store store
           (run-publish-server socket store
+                              #:advertise? advertise?
+                              #:port port
                               #:cache cache
                               #:pool (and cache (make-pool workers
                                                            #:thread-name
-- 
2.20.1