diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/system.scm | 65 |
1 files changed, 65 insertions, 0 deletions
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 |