Re: Adding Substitute Mirrors page to installer

[raid5atemyhomework]

Hello,

Below I have a patch that adds a page for substitute mirrors.

Limitation is that the substitute mirror is only used after installation 
completes.  During installation the guix daemon still loads from the Berlin 
server.  Also, channel is still the default Guix channel (which is fairly slow 
as well from some places).

Testing done:

* Create an install image by `./pre-inst-env guix system image -t iso9660 
gnu/system/install.scm` on a patched Guix.
* Create a new VM and install using the created install image.
* Select the SJTU mirror.
* Complete installation (also notice that during install, the mirror is *not* 
used, which could be confusing to users).
* On installation completion, reboot VM, then `guix pull` on root.
* Check that `guix pull` gets substitutes from SJTU mirror.

The ability to also use the same mirror *during* install rather than after it 
would be very nice.  After all, the guix daemon has to be restarted during 
installation in the meantime anyway, so on restart it should be possible to 
switch the `substitute-urls`.  However the complications are:

* The `(gnu installer service)` module inherently assumes that services are 
completely orthogonal to everything else being configured in the installation.  
I'm not sure what the best way to extract the substitute mirror selection would 
be.
* The installation image has to do a local `guix system reconfigure` of itself 
so that its shepherd points the guix daemon to a new mirror, so that the guix 
daemon restart in `install-system` of `(gnu installer final)` will refer to a 
new mirror.

> I agree that we need a convenient way to add mirrors, it can be critical
> to users who get low throughput from Berlin.

Indeed.

>
> To that I'd add the option to add channels straight from the installer.
> Not sure it belongs to a separate change set, maybe we can hit two birds
> we one stone here.

If you mean mirrors of the official Guix channel, this would be nice.

However, channels are not described in the `operating-system` declaration.  
Thus, we need to create channel by extra mechanism in installer.  This can 
probably be done by hooking somehow into `install-final` as well, as it creates 
the `/mnt` mountpoint for installing.

If you mean other non-Guix channels, the only channels I know of that are not 
Guix cannot be named here, so --- are there any channels that *can* be named in 
official documentation about Guix?

Thanks
raid5atemyhomework

>From af7e4d1336ed9010a31011d2fbae2a27fdaca237 Mon Sep 17 00:00:00 2001
From: raid5atemyhomework <raid5atemyhomework@protonmail.com>
Date: Wed, 10 Mar 2021 09:21:42 +0000
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/installer/newt/services.scm | 26 +++++++++++++-
 gnu/installer/services.scm      | 62 ++++++++++++++++++++++++++++-----
 2 files changed, 78 insertions(+), 10 deletions(-)

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
--
2.30.1