Re: Adding Substitute Mirrors page to installer

[raid5atemyhomework <raid5atemyhomework@protonmail.com>]

Hi zimoun,


> > Any chance of this getting reviewed and merge within the next five years?
>
> I understand your frustration. Could you please point which patch number ?


From 41b174da1e38b71563405f1be48331fbe0e5700d Mon Sep 17 00:00:00 2001
From: raid5atemyhomework <raid5atemyhomework@protonmail.com>
Date: Tue, 16 Mar 2021 23:45:37 +0800
Subject: [PATCH] gnu: Add substitute mirrors page to installer.

* gnu/installer/services.scm (system-service) [snippet-type]: New field.
(%system-services): Add substitute mirrors.
(service-list-service?): New procedure.
(modify-services-service?): New procedure.
(system-services->configuration): Add support for services with
`'modify-services` snippets.
* gnu/installer/newt/services.scm (run-substitute-mirror-page): New
procedure.
(run-services-page): Call `run-substitute-mirror-page`.
* gnu/services/base.scm (guix-shepherd-service)[start]: Accept second
argument, a space-separated list of substitute URLs.
* gnu/installer/final.scm (%user-modules): New variable.
(read-operating-system): New procedure.
(install-system): Read the installation configuration file and extract
substitute URLs to pass to `guix-daemon` start action.
* gnu/installer/tests.scm: Add new page in testing.
---
 gnu/installer/final.scm         | 37 +++++++++++++++++++-
 gnu/installer/newt/services.scm | 26 +++++++++++++-
 gnu/installer/services.scm      | 62 ++++++++++++++++++++++++++++-----
 gnu/installer/tests.scm         | 12 +++++--
 gnu/services/base.scm           | 15 ++++++--
 5 files changed, 136 insertions(+), 16 deletions(-)

diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm
index fc0b7803fa..2324c960f2 100644
--- a/gnu/installer/final.scm
+++ b/gnu/installer/final.scm
@@ -22,9 +22,13 @@
   #:use-module (gnu installer steps)
   #:use-module (gnu installer utils)
   #:use-module (gnu installer user)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
   #:use-module (gnu services herd)
+  #:use-module (gnu system)
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
+  #:use-module (guix ui)
   #:use-module (gnu build accounts)
   #:use-module (gnu build install)
   #:use-module (gnu build linux-container)
@@ -38,6 +42,20 @@
   #:use-module (ice-9 rdelim)
   #:export (install-system))

+;; XXX duplicated from guix/scripts/system.scm, but that pulls in
+;; (guix store database), which requires guile-sqlite which is not
+;; available in the installation environment.
+(define %user-module
+  ;; Module in which the machine description file is loaded.
+  (make-user-module '((gnu system)
+                      (gnu services)
+                      (gnu system shadow))))
+
+(define (read-operating-system file)
+  "Read the operating-system declaration from FILE and return it."
+  (load* file %user-module))
+;; XXX
+
 (define %seed
   (seed->random-state
    (logxor (getpid) (car (gettimeofday)))))
@@ -174,6 +192,16 @@ or #f.  Return #t on success and #f on failure."
                                   options
                                   (list (%installer-configuration-file)
                                         (%installer-target-dir))))
+         ;; Extract the substitute URLs of the user configuration.
+         (os              (read-operating-system (%installer-configuration-file)))
+         (substitute-urls (and (operating-system? os)
+                               (and=> (find
+                                        (lambda (service)
+                                          (eq? guix-service-type
+                                               (service-kind service)))
+                                        (operating-system-services os))
+                                      (compose guix-configuration-substitute-urls
+                                               service-value))))
          (database-dir    "/var/guix/db")
          (database-file   (string-append database-dir "/db.sqlite"))
          (saved-database  (string-append database-dir "/db.save"))
@@ -206,8 +234,15 @@ or #f.  Return #t on success and #f on failure."
            (lambda ()
              ;; We need to drag the guix-daemon to the container MNT
              ;; namespace, so that it can operate on the cow-store.
+             ;; Also we need to change the substitute URLs to whatever
+             ;; the user selected during setup, so that the mirrors are
+             ;; used during install, not just after install.
              (stop-service 'guix-daemon)
-             (start-service 'guix-daemon (list (number->string (getpid))))
+             (start-service 'guix-daemon
+                            `(,(number->string (getpid))
+                              ,@(if substitute-urls
+                                    `(,(string-join substitute-urls))
+                                    '())))

              (setvbuf (current-output-port) 'none)
              (setvbuf (current-error-port) 'none)
diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm
index 74f28e41ba..0fd5d3f2de 100644
--- a/gnu/installer/newt/services.scm
+++ b/gnu/installer/newt/services.scm
@@ -92,6 +92,29 @@ client may be enough for a server.")
         (condition
          (&installer-step-abort)))))))

+(define (run-substitute-mirror-page)
+  (let ((title (G_ "Substitute mirror")))
+    (run-listbox-selection-page
+      #:title title
+      #:info-text (G_ "Choose a server to get substitutes from.
+
+Depending on your location, the official substitutes server can be slow; \
+in that case, using a mirror may be faster.")
+      #:info-textbox-width 70
+      #:listbox-height 8
+      #:listbox-items (filter (lambda (service)
+                                (eq? 'substitute-mirror
+                                     (system-service-type service)))
+                              %system-services)
+      #:listbox-item->text (compose G_ system-service-name)
+      #:sort-listbox-items? #f
+      #:button-text (G_ "Exit")
+      #:button-callback-procedure
+      (lambda _
+        (raise
+          (condition
+            (&installer-step-abort)))))))
+
 (define (run-services-page)
   (let ((desktop (run-desktop-environments-cbt-page)))
     ;; When the user did not select any desktop services, and thus didn't get
@@ -100,4 +123,5 @@ client may be enough for a server.")
             (run-networking-cbt-page)
             (if (null? desktop)
                 (list (run-network-management-page))
-                '()))))
+                '())
+            (list (run-substitute-mirror-page)))))
diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm
index ec5ea30594..34d1e6f0de 100644
--- a/gnu/installer/services.scm
+++ b/gnu/installer/services.scm
@@ -41,6 +41,8 @@
   (type            system-service-type)           ;'desktop | 'networking
   (recommended?    system-service-recommended?    ;Boolean
                    (default #f))
+  (snippet-type    system-service-snippet-type    ;'service-list | 'modify-services
+                   (default 'service-list))
   (snippet         system-service-snippet         ;list of sexps
                    (default '()))
   (packages        system-service-packages        ;list of sexps
@@ -118,7 +120,31 @@
      (system-service
       (name (G_ "DHCP client (dynamic IP address assignment)"))
       (type 'network-management)
-      (snippet '((service dhcp-client-service-type)))))))
+      (snippet '((service dhcp-client-service-type))))
+
+     ;; Substitute mirrors.
+     (system-service
+       ;; We should give the full URI of the servers, so that
+       ;; the user has the opportunity to ping it or wget
+       ;; from it to at least manually evaluate speed.
+       (name (G_ "https://ci.guix.gnu.org (Berlin, official Guix substitute server)"))
+       (type 'substitute-mirror))
+     (system-service
+       (name (G_ "https://mirror.sjtu.edu.cn/guix (China, SJTU)"))
+       (type 'substitute-mirror)
+       (snippet-type 'modify-services)
+       (snippet '((guix-service-type config =>
+                                     (guix-configuration
+                                       (inherit config)
+                                       (substitute-urls
+                                         ;; cons* is better here, but we use
+                                         ;; (append (list ..) ...) in services
+                                         ;; below, so use the same for
+                                         ;; consistency.
+                                         (append
+                                           (list
+                                             "https://mirror.sjtu.edu.cn/guix")
+                                           %default-substitute-urls))))))))))

 (define (desktop-system-service? service)
   "Return true if SERVICE is a desktop environment service."
@@ -128,15 +154,33 @@
   "Return true if SERVICE is a desktop environment service."
   (eq? 'networking (system-service-type service)))

+(define (service-list-service? service)
+  (eq? 'service-list (system-service-snippet-type service)))
+
+(define (modify-services-service? service)
+  (eq? 'modify-services (system-service-snippet-type service)))
+
 (define (system-services->configuration services)
   "Return the configuration field for SERVICES."
-  (let* ((snippets (append-map system-service-snippet services))
-         (packages (append-map system-service-packages services))
-         (desktop? (find desktop-system-service? services))
-         (base     (if desktop?
-                       '%desktop-services
-                       '%base-services)))
-    (if (null? snippets)
+  (let* ((service-list-services     (filter service-list-service?
+                                      services))
+         (service-list-snippets     (append-map system-service-snippet
+                                                service-list-services))
+         (modify-services-services  (filter modify-services-service?
+                                      services))
+         (modify-services-snippets  (append-map system-service-snippet
+                                                modify-services-services))
+         (packages                  (append-map system-service-packages
+                                                services))
+         (desktop?                  (find desktop-system-service? services))
+         (base-variable             (if desktop?
+                                        '%desktop-services
+                                        '%base-services))
+         (base                      (if (null? modify-services-snippets)
+                                        base-variable
+                                        `(modify-services ,base-variable
+                                           ,@modify-services-snippets))))
+    (if (null? service-list-snippets)
         `(,@(if (null? packages)
                 '()
                 `((packages (append (list ,@packages)
@@ -146,7 +190,7 @@
                 '()
                 `((packages (append (list ,@packages)
                                     %base-packages))))
-          (services (append (list ,@snippets
+          (services (append (list ,@service-list-snippets

                                   ,@(if desktop?
                                         ;; XXX: Assume 'keyboard-layout' is in
diff --git a/gnu/installer/tests.scm b/gnu/installer/tests.scm
index 8ccd327a7c..fee1a50f6f 100644
--- a/gnu/installer/tests.scm
+++ b/gnu/installer/tests.scm
@@ -220,7 +220,10 @@ ROOT-PASSWORD, and USERS."
                                  (string-contains service "NSS"))))
                           (choose-network-management-tool?
                            (lambda (service)
-                             (string-contains service "DHCP"))))
+                             (string-contains service "DHCP")))
+                          (choose-mirror?
+                           (lambda (mirror)
+                             (string-contains mirror "https://"))))
   "Converse over PORT to choose networking services."
   (define desktop-environments '())

@@ -240,7 +243,12 @@ ROOT-PASSWORD, and USERS."
                      (multiple-choices? #f)
                      (items ,services))
      (null? desktop-environments)
-     (find choose-network-management-tool? services))))
+     (find choose-network-management-tool? services))
+
+    ((list-selection (title "Substitute mirror")
+                     (multiple-choices? #f)
+                     (items ,mirrors))
+     (find choose-mirror? mirrors))))

 (define (edit-configuration-file file)
   "Edit FILE, an operating system configuration file generated by the
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 24b3ea785b..22970f0b31 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -1632,6 +1632,15 @@ proxy of 'guix-daemon'...~%")
                   (define discover?
                     (or (getenv "discover") #$discover?))

+                  ;; When running the installer, we want installation to
+                  ;; use the substitute URLs selected by the user.
+                  ;; The installer will pass in the desired substitute
+                  ;; URLs as the second argument of the start action.
+                  (define substitute-urls
+                    (match args
+                      ((_ substitute-urls . __)  substitute-urls)
+                      (else                      #$(string-join substitute-urls))))
+
                   ;; Start the guix-daemon from a container, when supported,
                   ;; to solve an installation issue. See the comment below for
                   ;; more details.
@@ -1648,7 +1657,7 @@ proxy of 'guix-daemon'...~%")
                                  '("--no-substitutes"))
                           (string-append "--discover="
                                          (if discover? "yes" "no"))
-                          "--substitute-urls" #$(string-join substitute-urls)
+                          "--substitute-urls" substitute-urls
                           #$@extra-options

                           ;; Add CHROOT-DIRECTORIES and all their dependencies
@@ -1670,8 +1679,8 @@ proxy of 'guix-daemon'...~%")
                    ;; Otherwise, for symmetry purposes enter the caller
                    ;; namespaces which is a no-op.
                    #:pid (match args
-                           ((pid) (string->number pid))
-                           (else (getpid)))
+                           ((pid . _)   (string->number pid))
+                           (else        (getpid)))

                    #:environment-variables
                    (append (list #$@(if tmpdir
--
2.31.1