diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/lint.scm | 17 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 20 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 65 |
6 files changed, 100 insertions, 31 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 57bbeec465..fc61f0b547 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -33,6 +33,7 @@ #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix ui) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix memoization) #:use-module (guix scripts) @@ -73,6 +74,7 @@ check-mirror-url check-license check-vulnerabilities + check-for-updates check-formatting run-checkers @@ -826,6 +828,17 @@ from ~s: ~a (~s)~%") (string-join (map vulnerability-id unpatched) ", "))))))))) +(define (check-for-updates package) + "Check if there is an update available for PACKAGE." + (match (package-latest-release* package (force %updaters)) + ((? upstream-source? source) + (when (version>? (upstream-source-version source) + (package-version package)) + (emit-warning package + (format #f (G_ "can be upgraded to ~a") + (upstream-source-version source))))) + (#f #f))) ; cannot find newer upstream release + ;;; ;;; Source code formatting. @@ -992,6 +1005,10 @@ or a list thereof") (CVE) database") (check check-vulnerabilities)) (lint-checker + (name 'refresh) + (description "Check the package for new upstream releases") + (check check-for-updates)) + (lint-checker (name 'formatting) (description "Look for formatting issues in the source") (check check-formatting)))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4adc705220..0e365018a9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -604,12 +604,12 @@ and upgrades." (options->upgrade-predicate opts)) (define upgraded - (fold (lambda (entry transaction) - (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) - transaction)) - transaction - (manifest-entries manifest))) + (fold-right (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ade3c49a54..dd54f03996 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -484,9 +484,11 @@ requested using POOL." #:buffer-size (* 128 1024)) (rename-file (string-append nar ".tmp") nar)) ('none - ;; When compression is disabled, we retrieve files directly from the - ;; store; no need to cache them. - #t)) + ;; Cache nars even when compression is disabled so that we can + ;; guarantee the TTL (see <https://bugs.gnu.org/28664>.) + (with-atomic-file-output nar + (lambda (port) + (write-file item port))))) (mkdir-p (dirname narinfo)) (with-atomic-file-output narinfo @@ -788,8 +790,11 @@ blocking." ;; /nar/<store-item> ((components ... store-item) (if (nar-path? components) - (render-nar store request store-item - #:compression %no-compression) + (if cache + (render-nar/cached store cache request store-item + #:compression %no-compression) + (render-nar store request store-item + #:compression %no-compression)) (not-found request))) (x (not-found request))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index b1c87c870e..2400198000 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -82,7 +82,7 @@ Install it by running: (resolve-interface '(git)))) (define %repository-url - "https://git.savannah.gnu.org/git/guix.git") + (or (getenv "GUIX_PULL_URL") "https://git.savannah.gnu.org/git/guix.git")) ;;; diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 5add64d8e8..d638d744af 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -30,7 +30,6 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix upstream) - #:use-module (guix discovery) #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix monads) @@ -46,8 +45,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 binary-ports) - #:export (guix-refresh - %updaters)) + #:export (guix-refresh)) ;;; @@ -162,22 +160,6 @@ specified with `--select'.\n")) ;;; Updates. ;;; -(define (importer-modules) - "Return the list of importer modules." - (cons (resolve-interface '(guix gnu-maintenance)) - (all-modules (map (lambda (entry) - `(,entry . "guix/import")) - %load-path)))) - -(define %updaters - ;; The list of publically-known updaters. - (delay (fold-module-public-variables (lambda (obj result) - (if (upstream-updater? obj) - (cons obj result) - result)) - '() - (importer-modules)))) - (define (lookup-updater-by-name name) "Return the updater called NAME." (or (find (lambda (updater) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 567d8bb643..e50f1d8ac7 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -37,6 +37,8 @@ #:use-module (guix scripts graph) #:use-module (guix build utils) #:use-module (gnu build install) + #:autoload (gnu build file-systems) + (find-partition-by-label find-partition-by-uuid) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -404,6 +406,7 @@ NUMBERS, which is a list of generation numbers." "Roll back the system profile to its previous generation. STORE is an open connection to the store." (switch-to-system-generation store "-1")) + ;;; ;;; Switch generations. @@ -556,6 +559,61 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." ;;; +;;; File system declaration checks. +;;; + +(define (check-file-system-availability file-systems) + "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if +any, are available. Raise an error if they're not." + (define relevant + (filter (lambda (fs) + (and (file-system-mount? fs) + (not (string=? "tmpfs" (file-system-type fs))) + (not (memq 'bind-mount (file-system-flags fs))))) + file-systems)) + + (define labeled + (filter (lambda (fs) + (eq? (file-system-title fs) 'label)) + relevant)) + + (define uuid + (filter (lambda (fs) + (eq? (file-system-title fs) 'uuid)) + relevant)) + + (define fail? #f) + + (define (file-system-location* fs) + (location->string + (source-properties->location + (file-system-location fs)))) + + (let-syntax ((error (syntax-rules () + ((_ args ...) + (begin + (set! fail? #t) + (format (current-error-port) + args ...)))))) + (for-each (lambda (fs) + (unless (find-partition-by-label (file-system-device fs)) + (error (G_ "~a: error: file system with label '~a' not found~%") + (file-system-location* fs) + (file-system-device fs)))) + labeled) + (for-each (lambda (fs) + (unless (find-partition-by-uuid (file-system-device fs)) + (error (G_ "~a: error: file system with UUID '~a' not found~%") + (file-system-location* fs) + (uuid->string (file-system-device fs))))) + uuid) + + (when fail? + ;; Better be safe than sorry. + (exit 1)))) + + +;;; ;;; Action. ;;; @@ -637,6 +695,13 @@ output when building a system derivation, such as a disk image." (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull)) + ;; Check whether the declared file systems exist. This is better than + ;; instantiating a broken configuration. Assume that we can only check if + ;; running as root. + (when (and (memq action '(init reconfigure)) + (zero? (getuid))) + (check-file-system-availability (operating-system-file-systems os))) + (mlet* %store-monad ((sys (system-derivation-for-action os action #:file-system-type file-system-type |