From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:56486) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dzpj6-0005IU-JS for guix-patches@gnu.org; Wed, 04 Oct 2017 15:53:05 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dzpj5-0007Yj-Hk for guix-patches@gnu.org; Wed, 04 Oct 2017 15:53:04 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40576) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dzpj5-0007Ye-EN for guix-patches@gnu.org; Wed, 04 Oct 2017 15:53:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dzpj5-0004vq-77 for guix-patches@gnu.org; Wed, 04 Oct 2017 15:53:03 -0400 Subject: [bug#28706] [PATCH 3/3] guix system: Error out when passed a wrong file system UUID/label. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Wed, 4 Oct 2017 21:51:45 +0200 Message-Id: <20171004195145.4743-3-ludo@gnu.org> In-Reply-To: <20171004195145.4743-1-ludo@gnu.org> References: <20171004195145.4743-1-ludo@gnu.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 28706@debbugs.gnu.org * guix/scripts/system.scm (check-file-system-availability): New procedure. (perform-action): Use it. --- guix/scripts/system.scm | 65 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 567d8bb64..e50f1d8ac 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. @@ -555,6 +558,61 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (leave (G_ "invalid syntax: ~a~%") pattern)))) +;;; +;;; 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 -- 2.14.2