summaryrefslogtreecommitdiff
path: root/guix/scripts/pull.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/pull.scm')
-rw-r--r--guix/scripts/pull.scm153
1 files changed, 112 insertions, 41 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 10e1a99e54..188237aa90 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -20,6 +20,7 @@
(define-module (guix scripts pull)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module (guix status)
#:use-module (guix scripts)
#:use-module (guix store)
#:use-module (guix config)
@@ -61,6 +62,9 @@
`((system . ,(%current-system))
(substitutes? . #t)
(build-hook? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
(graft? . #t)
(verbosity . 0)))
@@ -180,9 +184,25 @@ Download and deploy the latest version of Guix.\n"))
(define (honor-x509-certificates store)
"Use the right X.509 certificates for Git checkouts over HTTPS."
- (let ((file (getenv "SSL_CERT_FILE"))
+ ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of
+ ;; files (instead of all the certificates) among which "ca-bundle.crt". On
+ ;; other distros /etc/ssl/certs usually contains the whole set of
+ ;; certificates along with "ca-certificates.crt". Try to choose the right
+ ;; one.
+ (let ((file (letrec-syntax ((choose
+ (syntax-rules ()
+ ((_ file rest ...)
+ (let ((f file))
+ (if (and f (file-exists? f))
+ f
+ (choose rest ...))))
+ ((_)
+ #f))))
+ (choose (getenv "SSL_CERT_FILE")
+ "/etc/ssl/certs/ca-certificates.crt"
+ "/etc/ssl/certs/ca-bundle.crt")))
(directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs")))
- (if (or (and file (file-exists? file))
+ (if (or file
(and=> (stat directory #f)
(lambda (st)
(> (stat:nlink st) 2))))
@@ -208,6 +228,60 @@ Download and deploy the latest version of Guix.\n"))
;;;
+;;; Profile.
+;;;
+
+(define %current-profile
+ ;; The "real" profile under /var/guix.
+ (string-append %profile-directory "/current-guix"))
+
+(define %user-profile-directory
+ ;; The user-friendly name of %CURRENT-PROFILE.
+ (string-append (config-directory #:ensure? #f) "/current"))
+
+(define (migrate-generations profile directory)
+ "Migrate the generations of PROFILE to DIRECTORY."
+ (format (current-error-port)
+ (G_ "Migrating profile generations to '~a'...~%")
+ %profile-directory)
+ (let ((current (generation-number profile)))
+ (for-each (lambda (generation)
+ (let ((source (generation-file-name profile generation))
+ (target (string-append directory "/current-guix-"
+ (number->string generation)
+ "-link")))
+ ;; Note: Don't use 'rename-file' as SOURCE and TARGET might
+ ;; live on different file systems.
+ (symlink (readlink source) target)
+ (delete-file source)))
+ (profile-generations profile))
+ (symlink (string-append "current-guix-"
+ (number->string current) "-link")
+ (string-append directory "/current-guix"))))
+
+(define (ensure-default-profile)
+ (ensure-profile-directory)
+
+ ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move
+ ;; them to %PROFILE-DIRECTORY.
+ (unless (string=? %profile-directory
+ (dirname (canonicalize-profile %user-profile-directory)))
+ (migrate-generations %user-profile-directory %profile-directory))
+
+ ;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
+ (let ((link %user-profile-directory))
+ (unless (equal? (false-if-exception (readlink link))
+ %current-profile)
+ (catch 'system-error
+ (lambda ()
+ (false-if-exception (delete-file link))
+ (symlink %current-profile link))
+ (lambda args
+ (leave (G_ "while creating symlink '~a': ~a~%")
+ link (strerror (system-error-errno args))))))))
+
+
+;;;
;;; Queries.
;;;
@@ -322,11 +396,8 @@ and ALIST2 differ, display HEADING upfront."
(display-new/upgraded-packages (package-alist gen1)
(package-alist gen2)))
-(define (process-query opts)
- "Process any query specified by OPTS."
- (define profile
- (string-append (config-directory) "/current"))
-
+(define (process-query opts profile)
+ "Process any query on PROFILE specified by OPTS."
(match (assoc-ref opts 'query)
(('list-generations pattern)
(define (list-generations profile numbers)
@@ -422,45 +493,45 @@ Use '~/.config/guix/channels.scm' instead."))
(list %default-options)))
(cache (string-append (cache-directory) "/pull"))
(channels (channel-list opts))
- (profile (or (assoc-ref opts 'profile)
- (string-append (config-directory) "/current"))))
-
+ (profile (or (assoc-ref opts 'profile) %current-profile)))
+ (ensure-default-profile)
(cond ((assoc-ref opts 'query)
- (process-query opts))
+ (process-query opts profile))
((assoc-ref opts 'dry-run?)
#t) ;XXX: not very useful
(else
(with-store store
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%repository-cache-directory cache))
- (set-build-options-from-command-line store opts)
- (honor-x509-certificates store)
+ (with-status-report print-build-event
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%repository-cache-directory cache))
+ (set-build-options-from-command-line store opts)
+ (honor-x509-certificates store)
- (let ((instances (latest-channel-instances store channels)))
- (format (current-error-port)
- (N_ "Building from this channel:~%"
- "Building from these channels:~%"
- (length instances)))
- (for-each (lambda (instance)
- (let ((channel
- (channel-instance-channel instance)))
- (format (current-error-port)
- " ~10a~a\t~a~%"
- (channel-name channel)
- (channel-url channel)
- (string-take
- (channel-instance-commit instance)
- 7))))
- instances)
- (parameterize ((%guile-for-build
- (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- (build-and-install instances profile
- #:verbose?
- (assoc-ref opts 'verbose?)))))))))))))
+ (let ((instances (latest-channel-instances store channels)))
+ (format (current-error-port)
+ (N_ "Building from this channel:~%"
+ "Building from these channels:~%"
+ (length instances)))
+ (for-each (lambda (instance)
+ (let ((channel
+ (channel-instance-channel instance)))
+ (format (current-error-port)
+ " ~10a~a\t~a~%"
+ (channel-name channel)
+ (channel-url channel)
+ (string-take
+ (channel-instance-commit instance)
+ 7))))
+ instances)
+ (parameterize ((%guile-for-build
+ (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2)))))
+ (run-with-store store
+ (build-and-install instances profile
+ #:verbose?
+ (assoc-ref opts 'verbose?))))))))))))))
;;; pull.scm ends here
generated by cgit v1.2.3 (git 2.50.1) at 2025-08-09 00:12:08 +0000