diff options
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/build.scm | 85 | ||||
-rw-r--r-- | guix/scripts/system.scm | 24 |
2 files changed, 75 insertions, 34 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 0571b874f1..57f2d82c5c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -25,9 +25,12 @@ #:use-module (guix packages) #:use-module (guix grafts) + #:use-module (guix utils) + ;; Use the procedure that destructures "NAME-VERSION" forms. - #:use-module ((guix utils) #:hide (package-name->name+version)) - #:use-module ((guix build utils) #:select (package-name->name+version)) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version))) #:use-module (guix monads) #:use-module (guix gexp) @@ -127,33 +130,37 @@ found. Return #f if no build log was found." (define register-root* (store-lift register-root)) -(define (package-with-source store p uri) +(define (numeric-extension? file-name) + "Return true if FILE-NAME ends with digits." + (string-every char-set:hex-digit (file-extension file-name))) + +(define (tarball-base-name file-name) + "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar +extensions." + ;; TODO: Factorize. + (cond ((not (file-extension file-name)) + file-name) + ((numeric-extension? file-name) + file-name) + ((string=? (file-extension file-name) "tar") + (file-sans-extension file-name)) + ((file-extension file-name) + => + (match-lambda + ("scm" file-name) + (else (tarball-base-name (file-sans-extension file-name))))) + (else + file-name))) + +(define* (package-with-source store p uri #:optional version) "Return a package based on P but with its source taken from URI. Extract the new package's version number from URI." - (define (numeric-extension? file-name) - ;; Return true if FILE-NAME ends with digits. - (string-every char-set:hex-digit (file-extension file-name))) - - (define (tarball-base-name file-name) - ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar - ;; extensions. - ;; TODO: Factorize. - (cond ((not (file-extension file-name)) - file-name) - ((numeric-extension? file-name) - file-name) - ((string=? (file-extension file-name) "tar") - (file-sans-extension file-name)) - ((file-extension file-name) - (tarball-base-name (file-sans-extension file-name))) - (else - file-name))) - (let ((base (tarball-base-name (basename uri)))) - (let-values (((name version) - (package-name->name+version base))) + (let-values (((_ version*) + (hyphen-package-name->name+version base))) (package (inherit p) - (version (or version (package-version p))) + (version (or version version* + (package-version p))) ;; Use #:recursive? #t to allow for directories. (source (download-to-store store uri @@ -173,8 +180,23 @@ the new package's version number from URI." matching URIs given in SOURCES." (define new-sources (map (lambda (uri) - (cons (package-name->name+version (basename uri)) - uri)) + (match (string-index uri #\=) + (#f + ;; Determine the package name and version from URI. + (call-with-values + (lambda () + (hyphen-package-name->name+version + (tarball-base-name (basename uri)))) + (lambda (name version) + (list name version uri)))) + (index + ;; What's before INDEX is a "PKG@VER" or "PKG" spec. + (call-with-values + (lambda () + (package-name->name+version (string-take uri index))) + (lambda (name version) + (list name version + (string-drop uri (+ 1 index)))))))) sources)) (lambda (store obj) @@ -182,10 +204,11 @@ matching URIs given in SOURCES." (result '())) (match obj ((? package? p) - (let ((source (assoc-ref sources (package-name p)))) - (if source - (package-with-source store p source) - p))) + (match (assoc-ref sources (package-name p)) + ((version source) + (package-with-source store p source version)) + (#f + p))) (_ obj))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 36aed3331f..ebcf3e4f3b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -44,6 +44,7 @@ #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) + #:use-module (gnu system mapped-devices) #:use-module (gnu system linux-container) #:use-module (gnu system uuid) #:use-module (gnu system vm) @@ -621,6 +622,22 @@ any, are available. Raise an error if they're not." ;; Better be safe than sorry. (exit 1)))) +(define (check-mapped-devices mapped-devices) + "Check that each of MAPPED-DEVICES is valid according to the 'check' +procedure of its type." + (for-each (lambda (md) + (let ((check (mapped-device-kind-check + (mapped-device-type md)))) + ;; We expect CHECK to raise an exception with a detailed + ;; '&message' if something goes wrong, but handle the case + ;; where it just returns #f. + (unless (check md) + (leave (G_ "~a: invalid '~a' mapped device~%") + (location->string + (source-properties->location + (mapped-device-location md))))))) + mapped-devices)) + ;;; ;;; Action. @@ -710,9 +727,10 @@ output when building a system derivation, such as a disk image." ;; 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))) + (when (memq action '(init reconfigure)) + (when (zero? (getuid)) + (check-file-system-availability (operating-system-file-systems os))) + (check-mapped-devices (operating-system-mapped-devices os))) (mlet* %store-monad ((sys (system-derivation-for-action os action |