[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Adding Substitute Mirrors page to installer
|
From: |
raid5atemyhomework |
|
Subject: |
Re: Adding Substitute Mirrors page to installer |
|
Date: |
Wed, 01 Dec 2021 22:49:10 +0000 |
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