diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 239 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 23 |
6 files changed, 182 insertions, 134 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index aa9c105f58..8725ddad88 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -23,6 +23,7 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix grafts) #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix gexp) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2cc5f366a7..0e462de4bf 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -35,6 +35,9 @@ #:use-module (gnu system file-systems) #:use-module (gnu packages) #:use-module (gnu packages bash) + #:use-module (gnu packages commencement) + #:use-module (gnu packages guile) + #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -45,19 +48,10 @@ #:use-module (srfi srfi-98) #:export (guix-environment)) -(define (evaluate-input-search-paths inputs search-paths) +(define (evaluate-profile-search-paths profile search-paths) "Evaluate SEARCH-PATHS, a list of search-path specifications, for the -directories corresponding to INPUTS, a list of (DERIVATION) or (DERIVATION -OUTPUT) tuples." - (let ((directories (map (match-lambda - (((? derivation? drv)) - (derivation->output-path drv)) - (((? derivation? drv) output) - (derivation->output-path drv output)) - (((? string? item)) - item)) - inputs))) - (evaluate-search-paths search-paths directories))) +directories in PROFILE, the store path of a profile." + (evaluate-search-paths search-paths (list profile))) ;; Protect some env vars from purification. Borrowed from nix-shell. (define %precious-variables @@ -81,11 +75,10 @@ as 'HOME' and 'USER' are left untouched." (((names . _) ...) names))))) -(define (create-environment inputs paths pure?) - "Set the environment variables specified by PATHS for all the packages -within INPUTS. When PURE? is #t, unset the variables in the current -environment. Otherwise, augment existing enviroment variables with additional -search paths." +(define (create-environment profile paths pure?) + "Set the environment variables specified by PATHS for PROFILE. When PURE? +is #t, unset the variables in the current environment. Otherwise, augment +existing enviroment variables with additional search paths." (when pure? (purify-environment)) (for-each (match-lambda ((($ <search-path-specification> variable _ separator) . value) @@ -94,15 +87,14 @@ search paths." (if (and current (not pure?)) (string-append value separator current) value))))) - (evaluate-input-search-paths inputs paths)) + (evaluate-profile-search-paths profile paths)) ;; Give users a way to know that they're in 'guix environment', so they can ;; adjust 'PS1' accordingly, for instance. (setenv "GUIX_ENVIRONMENT" "t")) -(define (show-search-paths inputs search-paths pure?) - "Display SEARCH-PATHS applied to the packages specified by INPUTS, a list of - (DERIVATION) or (DERIVATION OUTPUT) tuples. When PURE? is #t, do not augment +(define (show-search-paths profile search-paths pure?) + "Display SEARCH-PATHS applied to PROFILE. When PURE? is #t, do not augment existing environment variables with additional search paths." (for-each (match-lambda ((search-path . value) @@ -110,12 +102,37 @@ existing environment variables with additional search paths." (search-path-definition search-path value #:kind (if pure? 'exact 'prefix))) (newline))) - (evaluate-input-search-paths inputs search-paths))) + (evaluate-profile-search-paths profile search-paths))) + +(define (strip-input-name input) + "Remove the name element from the tuple INPUT." + (match input + ((_ package) package) + ((_ package output) + (list package output)))) (define (package+propagated-inputs package output) "Return the union of PACKAGE's OUTPUT and its transitive propagated inputs." - `((,(package-name package) ,package ,output) - ,@(package-transitive-propagated-inputs package))) + (cons (list package output) + (map strip-input-name + (package-transitive-propagated-inputs package)))) + +(define (package-or-package+output? expr) + "Return #t if EXPR is a package or a 2 element list consisting of a package +and an output string." + (match expr + ((or (? package?) ; bare package object + ((? package?) (? string?))) ; package+output tuple + #t) + (_ #f))) + +(define (package-environment-inputs package) + "Return a list of the transitive input packages for PACKAGE." + ;; Remove non-package inputs such as origin records. + (filter package-or-package+output? + (map strip-input-name + (bag-transitive-inputs + (package->bag package))))) (define (show-help) (display (_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...] @@ -252,17 +269,19 @@ COMMAND or an interactive shell in that environment.\n")) (define (options/resolve-packages opts) "Return OPTS with package specification strings replaced by actual packages." - (define (package->outputs package mode) - (map (lambda (output) - (list mode package output)) - (package-outputs package))) + (define (package->output package mode) + (match package + ((? package?) + (list mode package "out")) + (((? package? package) (? string? output)) + (list mode package output)))) (define (packages->outputs packages mode) (match packages - ((? package? package) - (package->outputs package mode)) - (((? package? packages) ...) - (append-map (cut package->outputs <> mode) packages)))) + ((? package-or-package+output? package) ; single package + (list (package->output package mode))) + (((? package-or-package+output?) ...) ; many packages + (map (cut package->output <> mode) packages)))) (compact (append-map (match-lambda @@ -280,22 +299,30 @@ packages." (_ '(#f))) opts))) -(define (build-inputs inputs opts) - "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION -OUTPUT) tuples, using the build options in OPTS." +(define* (build-environment derivations opts) + "Build the DERIVATIONS required by the environment using the build options +in OPTS." (let ((substitutes? (assoc-ref opts 'substitutes?)) (dry-run? (assoc-ref opts 'dry-run?))) - (match inputs - (((derivations _ ...) ...) - (mbegin %store-monad - (show-what-to-build* derivations - #:use-substitutes? substitutes? - #:dry-run? dry-run?) - (if dry-run? - (return #f) - (mbegin %store-monad - (built-derivations derivations) - (return derivations)))))))) + (mbegin %store-monad + (show-what-to-build* derivations + #:use-substitutes? substitutes? + #:dry-run? dry-run?) + (if dry-run? + (return #f) + (mbegin %store-monad + (set-build-options-from-command-line* opts) + (built-derivations derivations)))))) + +(define (inputs->profile-derivation inputs system bootstrap?) + "Return the derivation for a profile consisting of INPUTS for SYSTEM. +BOOTSTRAP? specifies whether to use the bootstrap Guile to build the +profile." + (profile-derivation (packages->manifest inputs) + #:system system + #:hooks (if bootstrap? + '() + %default-profile-hooks))) (define requisites* (store-lift requisites)) @@ -334,16 +361,15 @@ variables are cleared before setting the new ones." (apply system* command)) (define* (launch-environment/container #:key command bash user-mappings - inputs paths network?) - "Run COMMAND within a Linux container. The environment features INPUTS, a -list of derivations to be shared from the host system. Environment variables -are set according to PATHS, a list of native search paths. The global shell -is BASH, a file name for a GNU Bash binary in the store. When NETWORK?, -access to the host system network is permitted. USER-MAPPINGS, a list of file -system mappings, contains the user-specified host file systems to mount inside -the container." + profile paths network?) + "Run COMMAND within a container that features the software in PROFILE. +Environment variables are set according to PATHS, a list of native search +paths. The global shell is BASH, a file name for a GNU Bash binary in the +store. When NETWORK?, access to the host system network is permitted. +USER-MAPPINGS, a list of file system mappings, contains the user-specified +host file systems to mount inside the container." (mlet %store-monad ((reqs (inputs->requisites - (cons (direct-store-path bash) inputs)))) + (list (direct-store-path bash) profile)))) (return (let* ((cwd (getcwd)) ;; Bind-mount all requisite store items, user-specified mappings, @@ -408,7 +434,7 @@ the container." (primitive-exit/status ;; A container's environment is already purified, so no need to ;; request it be purified again. - (launch-environment command inputs paths #f))) + (launch-environment command profile paths #f))) #:namespaces (if network? (delq 'net %namespaces) ; share host network %namespaces))))))) @@ -482,64 +508,65 @@ message if any test fails." (('ad-hoc-package package output) (package+propagated-inputs package output)) - (('package package output) - (bag-transitive-inputs - (package->bag package)))) + (('package package _) + (package-environment-inputs package))) packages))) (paths (delete-duplicates (cons $PATH (append-map (match-lambda - ((label (? package? p) _ ...) - (package-native-search-paths p)) - (_ - '())) + ((or ((? package? p) _ ...) + (? package? p)) + (package-native-search-paths p)) + (_ '())) inputs)) eq?))) (when container? (assert-container-features)) (with-store store - (set-build-options-from-command-line store opts) - (run-with-store store - (mlet* %store-monad ((inputs (lower-inputs - (map (match-lambda - ((label item) - (list item)) - ((label item output) - (list item output))) - inputs) - #:system system)) - ;; Containers need a Bourne shell at /bin/sh. - (bash (environment-bash container? - bootstrap? - system))) - (mbegin %store-monad + ;; Use the bootstrap Guile when requested. + (parameterize ((%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (canonical-package guile-2.0))))) + (set-build-options-from-command-line store opts) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (inputs->profile-derivation + inputs system bootstrap?)) + (profile -> (derivation->output-path prof-drv))) ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash - ;; for a container. - (build-inputs (if (derivation? bash) - `((,bash "out") ,@inputs) - inputs) - opts) - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths inputs paths pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - bash - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user-mappings mappings - #:inputs inputs - #:paths paths - #:network? network?))) - (else - (return - (exit/status - (launch-environment command inputs paths pure?)))))))))))) + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (build-environment (if (derivation? bash) + (list prof-drv bash) + (list prof-drv)) + opts) + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths profile paths pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user-mappings mappings + #:profile profile + #:paths paths + #:network? network?))) + (else + (return + (exit/status + (launch-environment command profile paths pure?))))))))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b93ffb0b6b..f65834386b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> -;;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -551,10 +551,6 @@ upgrading, #f otherwise." (define (options->installable opts manifest) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', return the new list of manifest entries." - (define (package->manifest-entry* package output) - (check-package-freshness package) - (package->manifest-entry package output)) - (define upgrade? (options->upgrade-predicate opts)) @@ -567,7 +563,7 @@ return the new list of manifest entries." (call-with-values (lambda () (specification->package+output name output)) - package->manifest-entry*)))) + package->manifest-entry)))) (_ #f)) (manifest-entries manifest))) @@ -576,13 +572,13 @@ return the new list of manifest entries." (('install . (? package? p)) ;; When given a package via `-e', install the first of its ;; outputs (XXX). - (package->manifest-entry* p "out")) + (package->manifest-entry p "out")) (('install . (? string? spec)) (if (store-path? spec) (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (package->manifest-entry* package output)))) + (package->manifest-entry package output)))) (_ #f)) opts)) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index fb7b4218e0..46292131d7 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -142,10 +142,11 @@ Publish ~a over HTTP.\n") %store-directory) (define base64-encode-string (compose base64-encode string->utf8)) -(define (narinfo-string store-path path-info key) - "Generate a narinfo key/value string for STORE-PATH using the details in -PATH-INFO. The narinfo is signed with KEY." - (let* ((url (string-append "nar/" (basename store-path))) +(define (narinfo-string store store-path key) + "Generate a narinfo key/value string for STORE-PATH; an exception is raised +if STORE-PATH is invalid. The narinfo is signed with KEY." + (let* ((path-info (query-path-info store store-path)) + (url (string-append "nar/" (basename store-path))) (hash (bytevector->nix-base32-string (path-info-hash path-info))) (size (path-info-nar-size path-info)) @@ -163,7 +164,7 @@ References: ~a~%" store-path url hash size references)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. - (info (if (string-null? deriver) + (info (if (not deriver) base-info (catch 'system-error (lambda () @@ -199,23 +200,21 @@ References: ~a~%" (define (render-narinfo store request hash) "Render metadata for the store path corresponding to HASH." - (let* ((store-path (hash-part->path store hash)) - (path-info (and (not (string-null? store-path)) - (query-path-info store store-path)))) - (if path-info + (let ((store-path (hash-part->path store hash))) + (if (string-null? store-path) + (not-found request) (values '((content-type . (application/x-nix-narinfo))) (cut display - (narinfo-string store-path path-info (force %private-key)) - <>)) - (not-found request)))) + (narinfo-string store store-path (force %private-key)) + <>))))) -(define (render-nar request store-item) +(define (render-nar store request store-item) "Render archive of the store path corresponding to STORE-ITEM." (let ((store-path (string-append %store-directory "/" store-item))) ;; The ISO-8859-1 charset *must* be used otherwise HTTP clients will ;; interpret the byte stream as UTF-8 and arbitrarily change invalid byte ;; sequences. - (if (file-exists? store-path) + (if (valid-path? store store-path) (values '((content-type . (application/x-nix-archive (charset . "ISO-8859-1")))) ;; XXX: We're not returning the actual contents, deferring @@ -315,7 +314,7 @@ blocking." (render-narinfo store request hash)) ;; /nar/<store-item> (("nar" store-item) - (render-nar request store-item)) + (render-nar store request store-item)) (_ (not-found request))) (not-found request)))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index f9e3f31a03..e541138682 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +32,7 @@ #:use-module (guix scripts graph) #:use-module (guix monads) #:use-module ((guix gnu-maintenance) - #:select (%gnu-updater %gnome-updater)) + #:select (%gnu-updater %gnome-updater %xorg-updater)) #:use-module (guix import elpa) #:use-module (guix import cran) #:use-module (guix gnupg) @@ -193,10 +194,13 @@ unavailable optional dependencies such as Guile-JSON." ;; List of "updaters" used by default. They are consulted in this order. (list-updaters %gnu-updater %gnome-updater + %xorg-updater %elpa-updater %cran-updater %bioconductor-updater - ((guix import pypi) => %pypi-updater))) + ((guix import pypi) => %pypi-updater) + ((guix import gem) => %gem-updater) + ((guix import github) => %github-updater))) (define (lookup-updater name) "Return the updater called NAME." diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7279be0c43..401aa8b60a 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -211,6 +211,19 @@ the ownership of '~a' may be incorrect!~%") (lambda () (environ env))))) +(define-syntax-rule (save-load-path-excursion body ...) + "Save the current values of '%load-path' and '%load-compiled-path', run +BODY..., and restore them." + (let ((path %load-path) + (cpath %load-compiled-path)) + (dynamic-wind + (const #t) + (lambda () + body ...) + (lambda () + (set! %load-path path) + (set! %load-compiled-path cpath))))) + (define-syntax-rule (warn-on-system-error body ...) (catch 'system-error (lambda () @@ -273,6 +286,9 @@ bring the system down." (info (_ "loading new services:~{ ~a~}...~%") to-load-names) (mlet %store-monad ((files (mapm %store-monad shepherd-service-file to-load))) + ;; Here we assume that FILES are exactly those that were computed + ;; as part of the derivation that built OS, which is normally the + ;; case. (load-services (map derivation->output-path files)) (for-each start-service @@ -299,7 +315,12 @@ it atomically, and then run OS's activation script." ;; Tell 'activate-current-system' what the new system is. (setenv "GUIX_NEW_SYSTEM" system) - (primitive-load (derivation->output-path script))) + ;; The activation script may modify '%load-path' & co., so protect + ;; against that. This is necessary to ensure that + ;; 'upgrade-shepherd-services' gets to see the right modules when it + ;; computes derivations with (gexp->derivation #:modules …). + (save-load-path-excursion + (primitive-load (derivation->output-path script)))) ;; Finally, try to update system services. (upgrade-shepherd-services os)))) |