diff options
author | Mathieu Othacehe <othacehe@gnu.org> | 2020-11-24 14:05:21 +0100 |
---|---|---|
committer | Mathieu Othacehe <othacehe@gnu.org> | 2020-11-29 15:08:26 +0100 |
commit | 79f9dee3c4c0e6d21066f142116a537207ae7ba4 (patch) | |
tree | 9e7cf7e45d07a529576eb4addabe578dc35cf7d5 /guix | |
parent | 276e494b2a1fd87874d80e2bdc3aa1fb833b76f2 (diff) |
Use substitute servers on the local network.
* guix/scripts/discover.scm: New file.
* Makefile.am (MODULES): Add it.
* nix/nix-daemon/guix-daemon.cc (options): Add "discover" option,
(parse-opt): parse it,
(main): start "guix discover" process when the option is set.
* guix/scripts/substitute.scm (%local-substitute-urls): New variable,
(substitute-urls): add it.
* gnu/services/base.scm (<guix-configuration>): Add "discover?"
field,
(guix-shepherd-service): honor it.
* doc/guix.texi (Invoking guix-daemon): Document "discover" option,
(Base Services): ditto.
Diffstat (limited to 'guix')
-rw-r--r-- | guix/scripts/discover.scm | 158 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 32 |
2 files changed, 189 insertions, 1 deletions
diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm new file mode 100644 index 0000000000..b17dbdcb3c --- /dev/null +++ b/guix/scripts/discover.scm @@ -0,0 +1,158 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts discover) + #:use-module (guix avahi) + #:use-module (guix config) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (guix scripts publish) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-37) + #:export (read-substitute-urls + + guix-discover)) + +(define (show-help) + (format #t (G_ "Usage: guix discover [OPTION]... +Discover Guix related services using Avahi.\n")) + (display (G_ " + -c, --cache=DIRECTORY cache discovery results in DIRECTORY")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + (list (option '(#\c "cache") #t #f + (lambda (opt name arg result) + (alist-cons 'cache arg result))) + (option '(#\h "help") #f #f + (lambda _ + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda _ + (show-version-and-exit "guix discover"))))) + +(define %default-options + `((cache . ,%state-directory))) + + +;;; +;;; Publish servers. +;;; + +(define %publish-services + ;; Set of discovered publish services. + (make-hash-table)) + +(define (publish-file cache-directory) + "Return the name of the file storing the discovered publish services inside +CACHE-DIRECTORY." + (let ((directory (string-append cache-directory "/discover"))) + (string-append directory "/publish"))) + +(define %publish-file + (make-parameter (publish-file %state-directory))) + +(define* (write-publish-file #:key (file (%publish-file))) + "Dump the content of %PUBLISH-SERVICES hash table into FILE. Use a write +lock on FILE to synchronize with any potential readers." + (with-file-lock file + (call-with-output-file file + (lambda (port) + (hash-for-each + (lambda (name service) + (format port "http://~a:~a~%" + (avahi-service-address service) + (avahi-service-port service))) + %publish-services))) + (chmod file #o644))) + +(define (call-with-read-file-lock file thunk) + "Call THUNK with a read lock on FILE." + (let ((port #f)) + (dynamic-wind + (lambda () + (set! port + (let ((port (open-file file "r0"))) + (fcntl-flock port 'read-lock) + port))) + thunk + (lambda () + (when port + (unlock-file port)))))) + +(define-syntax-rule (with-read-file-lock file exp ...) + "Wait to acquire a read lock on FILE and evaluate EXP in that context." + (call-with-read-file-lock file (lambda () exp ...))) + +(define* (read-substitute-urls #:key (file (%publish-file))) + "Read substitute urls list from FILE and return it. Use a read lock on FILE +to synchronize with the writer." + (with-read-file-lock file + (call-with-input-file file + (lambda (port) + (let loop ((url (read-line port)) + (urls '())) + (if (eof-object? url) + urls + (loop (read-line port) (cons url urls)))))))) + + +;;; +;;; Entry point. +;;; + +(define %services + ;; List of services we want to discover. + (list publish-service-type)) + +(define (service-proc action service) + (let ((name (avahi-service-name service)) + (type (avahi-service-type service))) + (when (string=? type publish-service-type) + (case action + ((new-service) + (hash-set! %publish-services name service)) + ((remove-service) + (hash-remove! %publish-services name))) + (write-publish-file)))) + +(define-command (guix-discover . args) + (category internal) + (synopsis "discover Guix related services using Avahi") + + (with-error-handling + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (leave (G_ "~A: extraneous argument~%") arg)) + %default-options)) + (cache (assoc-ref opts 'cache)) + (publish-file (publish-file cache))) + (parameterize ((%publish-file publish-file)) + (mkdir-p (dirname publish-file)) + (avahi-browse-service-thread service-proc + #:types %services))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ddb885d344..8e5953b877 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -27,6 +27,7 @@ #:use-module (guix config) #:use-module (guix records) #:use-module ((guix serialization) #:select (restore-file)) + #:use-module (guix scripts discover) #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix base64) @@ -1078,9 +1079,38 @@ found." ;; daemon. '("http://ci.guix.gnu.org")))) +;; In order to prevent using large number of discovered local substitute +;; servers, limit the local substitute urls list size. +(define %max-substitute-urls 50) + +(define* (randomize-substitute-urls urls + #:key + (max %max-substitute-urls)) + "Return a list containing MAX urls from URLS, picked randomly. If URLS list +is shorter than MAX elements, then it is directly returned." + (define (random-item list) + (list-ref list (random (length list)))) + + (if (<= (length urls) max) + urls + (let loop ((res '()) + (urls urls)) + (if (eq? (length res) max) + res + (let ((url (random-item urls))) + (loop (cons url res) (delete url urls))))))) + +(define %local-substitute-urls + ;; If the following option is passed to the daemon, use the substitutes list + ;; provided by "guix discover" process. + (if (find-daemon-option "discover") + (randomize-substitute-urls (read-substitute-urls)) + '())) + (define substitute-urls ;; List of substitute URLs. - (make-parameter %default-substitute-urls)) + (make-parameter (append %local-substitute-urls + %default-substitute-urls))) (define (client-terminal-columns) "Return the number of columns in the client's terminal, if it is known, or a |