diff options
author | Mark H Weaver <mhw@netris.org> | 2013-02-14 04:15:25 -0500 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2013-02-16 22:17:37 -0500 |
commit | e49951eb3e1e1a8e7bad6d7471483e70b0865352 (patch) | |
tree | 7924fec33724f1de6a1cdd0757c7ebe38c7bee6b /guix-package.in | |
parent | 040860152e63bbafb2eb3e93619e18d107c96b55 (diff) | |
download | guix-e49951eb3e1e1a8e7bad6d7471483e70b0865352.tar guix-e49951eb3e1e1a8e7bad6d7471483e70b0865352.tar.gz |
Replace individual scripts with master 'guix' script.
* scripts/guix.in: New script.
* Makefile.am (bin_SCRIPTS): Add 'scripts/guix'. Remove 'guix-build',
'guix-download', 'guix-import', 'guix-package', and 'guix-gc'.
(MODULES): Add 'guix/scripts/build.scm', 'guix/scripts/download.scm',
'guix/scripts/import.scm', 'guix/scripts/package.scm', and
'guix/scripts/gc.scm'.
* configure.ac (AC_CONFIG_FILES): Add 'scripts/guix'. Remove 'guix-build',
'guix-download', 'guix-import', 'guix-package', and 'guix-gc'.
* guix-build.in, guix-download.in, guix-gc.in, guix-import.in,
guix-package.in: Remove shell script boilerplate. Move to guix-COMMAND.in
to guix/scripts/COMMAND.scm. Rename module from (guix-COMMAND) to
(guix scripts COMMAND). Change "guix-COMMAND" to "guix COMMAND" in
usage help string.
* pre-inst-env.in: Add "@abs_top_builddir@/scripts" to the front of $PATH.
Export $GUIX_UNINSTALLED.
* tests/guix-build.sh, tests/guix-daemon.sh, tests/guix-download.sh,
tests/guix-gc.sh, tests/guix-package.sh: Use "guix COMMAND" instead of
"guix-COMMAND".
* doc/guix.texi: Replace all occurrences of "guix-COMMAND" with
"guix COMMAND".
* po/POTFILES.in: Update.
Diffstat (limited to 'guix-package.in')
-rw-r--r-- | guix-package.in | 706 |
1 files changed, 0 insertions, 706 deletions
diff --git a/guix-package.in b/guix-package.in deleted file mode 100644 index 584481acd5..0000000000 --- a/guix-package.in +++ /dev/null @@ -1,706 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code - -prefix="@prefix@" -datarootdir="@datarootdir@" - -GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" -export GUILE_LOAD_COMPILED_PATH - -main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')' -exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ - -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (guix-package) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix derivations) - #:use-module (guix packages) - #:use-module (guix utils) - #:use-module (guix config) - #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) - #:use-module (ice-9 ftw) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 vlist) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-37) - #:use-module (gnu packages) - #:use-module ((gnu packages base) #:select (guile-final)) - #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) - #:export (guix-package)) - -(define %store - (make-parameter #f)) - - -;;; -;;; User environment. -;;; - -(define %user-environment-directory - (and=> (getenv "HOME") - (cut string-append <> "/.guix-profile"))) - -(define %profile-directory - (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/" - (or (and=> (getenv "USER") - (cut string-append "per-user/" <>)) - "default"))) - -(define %current-profile - ;; Call it `guix-profile', not `profile', to allow Guix profiles to - ;; coexist with Nix profiles. - (string-append %profile-directory "/guix-profile")) - -(define (profile-manifest profile) - "Return the PROFILE's manifest." - (let ((manifest (string-append profile "/manifest"))) - (if (file-exists? manifest) - (call-with-input-file manifest read) - '(manifest (version 1) (packages ()))))) - -(define (manifest-packages manifest) - "Return the packages listed in MANIFEST." - (match manifest - (('manifest ('version 0) - ('packages ((name version output path) ...))) - (zip name version output path - (make-list (length name) '()))) - - ;; Version 1 adds a list of propagated inputs to the - ;; name/version/output/path tuples. - (('manifest ('version 1) - ('packages (packages ...))) - packages) - - (_ - (error "unsupported manifest format" manifest)))) - -(define (profile-regexp profile) - "Return a regular expression that matches PROFILE's name and number." - (make-regexp (string-append "^" (regexp-quote (basename profile)) - "-([0-9]+)"))) - -(define (profile-numbers profile) - "Return the list of generation numbers of PROFILE, or '(0) if no -former profiles were found." - (define* (scandir name #:optional (select? (const #t)) - (entry<? (@ (ice-9 i18n) string-locale<?))) - ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. - (define (enter? dir stat result) - (and stat (string=? dir name))) - - (define (visit basename result) - (if (select? basename) - (cons basename result) - result)) - - (define (leaf name stat result) - (and result - (visit (basename name) result))) - - (define (down name stat result) - (visit "." '())) - - (define (up name stat result) - (visit ".." result)) - - (define (skip name stat result) - ;; All the sub-directories are skipped. - (visit (basename name) result)) - - (define (error name* stat errno result) - (if (string=? name name*) ; top-level NAME is unreadable - result - (visit (basename name*) result))) - - (and=> (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry<?)))) - - (match (scandir (dirname profile) - (cute regexp-exec (profile-regexp profile) <>)) - (#f ; no profile directory - '(0)) - (() ; no profiles - '(0)) - ((profiles ...) ; former profiles around - (map (compose string->number - (cut match:substring <> 1) - (cute regexp-exec (profile-regexp profile) <>)) - profiles)))) - -(define (previous-profile-number profile number) - "Return the number of the generation before generation NUMBER of -PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the -case when generations have been deleted (there are \"holes\")." - (fold (lambda (candidate highest) - (if (and (< candidate number) (> candidate highest)) - candidate - highest)) - 0 - (profile-numbers profile))) - -(define (profile-derivation store packages) - "Return a derivation that builds a profile (a user environment) with -all of PACKAGES, a list of name/version/output/path/deps tuples." - (define builder - `(begin - (use-modules (ice-9 pretty-print) - (guix build union)) - - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let ((output (assoc-ref %outputs "out")) - (inputs (map cdr %build-inputs))) - (format #t "building user environment `~a' with ~a packages...~%" - output (length inputs)) - (union-build output inputs) - (call-with-output-file (string-append output "/manifest") - (lambda (p) - (pretty-print '(manifest (version 1) - (packages ,packages)) - p)))))) - - (build-expression->derivation store "user-environment" - (%current-system) - builder - (append-map (match-lambda - ((name version output path deps) - `((,name ,path) - ,@deps))) - packages) - #:modules '((guix build union)))) - -(define (profile-number profile) - "Return PROFILE's number or 0. An absolute file name must be used." - (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) - (basename (readlink profile)))) - (compose string->number (cut match:substring <> 1))) - 0)) - -(define (switch-symlinks link target) - "Atomically switch LINK, a symbolic link, to point to TARGET. Works -both when LINK already exists and when it does not." - (let ((pivot (string-append link ".new"))) - (symlink target pivot) - (rename-file pivot link))) - -(define (roll-back profile) - "Roll back to the previous generation of PROFILE." - (let* ((number (profile-number profile)) - (previous-number (previous-profile-number profile number)) - (previous-profile (format #f "~a-~a-link" - profile previous-number)) - (manifest (string-append previous-profile "/manifest"))) - - (define (switch-link) - ;; Atomically switch PROFILE to the previous profile. - (format #t (_ "switching from generation ~a to ~a~%") - number previous-number) - (switch-symlinks profile previous-profile)) - - (cond ((not (file-exists? profile)) ; invalid profile - (format (current-error-port) - (_ "error: profile `~a' does not exist~%") - profile)) - ((zero? number) ; empty profile - (format (current-error-port) - (_ "nothing to do: already at the empty profile~%"))) - ((or (zero? previous-number) ; going to emptiness - (not (file-exists? previous-profile))) - (let*-values (((drv-path drv) - (profile-derivation (%store) '())) - ((prof) - (derivation-output-path - (assoc-ref (derivation-outputs drv) "out")))) - (when (not (build-derivations (%store) (list drv-path))) - (leave (_ "failed to build the empty profile~%"))) - - (switch-symlinks previous-profile prof) - (switch-link))) - (else (switch-link))))) ; anything else - -(define (find-packages-by-description rx) - "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of -matching packages." - (define (same-location? p1 p2) - ;; Compare locations of two packages. - (equal? (package-location p1) (package-location p2))) - - (delete-duplicates - (sort - (fold-packages (lambda (package result) - (define matches? - (cut regexp-exec rx <>)) - - (if (or (and=> (package-synopsis package) - (compose matches? gettext)) - (and=> (package-description package) - (compose matches? gettext))) - (cons package result) - result)) - '()) - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2)))) - same-location?)) - -(define (input->name+path input) - "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." - (let loop ((input input)) - (match input - ((name package) - (loop `(,name ,package "out"))) - ((name package sub-drv) - (let*-values (((_ drv) - (package-derivation (%store) package)) - ((out) - (derivation-output-path - (assoc-ref (derivation-outputs drv) sub-drv)))) - `(,name ,out)))))) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((profile . ,%current-profile))) - -(define (show-help) - (display (_ "Usage: guix-package [OPTION]... PACKAGES... -Install, remove, or upgrade PACKAGES in a single transaction.\n")) - (display (_ " - -i, --install=PACKAGE install PACKAGE")) - (display (_ " - -r, --remove=PACKAGE remove PACKAGE")) - (display (_ " - -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) - (display (_ " - --roll-back roll back to the previous generation")) - (newline) - (display (_ " - -p, --profile=PROFILE use PROFILE instead of the user's default profile")) - (display (_ " - -n, --dry-run show what would be done without actually doing it")) - (display (_ " - --bootstrap use the bootstrap Guile to build the profile")) - (display (_ " - --verbose produce verbose output")) - (newline) - (display (_ " - -s, --search=REGEXP search in synopsis and description using REGEXP")) - (display (_ " - -I, --list-installed[=REGEXP] - list installed packages matching REGEXP")) - (display (_ " - -A, --list-available[=REGEXP] - list available packages matching REGEXP")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specification of the command-line options. - (list (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-package"))) - - (option '(#\i "install") #t #f - (lambda (opt name arg result) - (alist-cons 'install arg result))) - (option '(#\r "remove") #t #f - (lambda (opt name arg result) - (alist-cons 'remove arg result))) - (option '(#\u "upgrade") #t #f - (lambda (opt name arg result) - (alist-cons 'upgrade arg result))) - (option '("roll-back") #f #f - (lambda (opt name arg result) - (alist-cons 'roll-back? #t result))) - (option '(#\p "profile") #t #f - (lambda (opt name arg result) - (alist-cons 'profile arg - (alist-delete 'profile result)))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result) - (alist-cons 'dry-run? #t result))) - (option '("bootstrap") #f #f - (lambda (opt name arg result) - (alist-cons 'bootstrap? #t result))) - (option '("verbose") #f #f - (lambda (opt name arg result) - (alist-cons 'verbose? #t result))) - (option '(#\s "search") #t #f - (lambda (opt name arg result) - (cons `(query search ,(or arg "")) - result))) - (option '(#\I "list-installed") #f #t - (lambda (opt name arg result) - (cons `(query list-installed ,(or arg "")) - result))) - (option '(#\A "list-available") #f #t - (lambda (opt name arg result) - (cons `(query list-available ,(or arg "")) - result))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-package . args) - (define (parse-options) - ;; Return the alist of option values. - (args-fold args %options - (lambda (opt name arg result) - (leave (_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (_ "~A: extraneous argument~%") arg)) - %default-options)) - - (define (guile-missing?) - ;; Return #t if %GUILE-FOR-BUILD is not available yet. - (let ((out (derivation-path->output-path (%guile-for-build)))) - (not (valid-path? (%store) out)))) - - (define (show-what-to-build drv dry-run?) - ;; Show what will/would be built in realizing the derivations listed - ;; in DRV. - (let* ((req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build - (%store) d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cute valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req))))) - (if dry-run? - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)))) - - (define newest-available-packages - (memoize find-newest-available-packages)) - - (define (find-best-packages-by-name name version) - (if version - (find-packages-by-name name version) - (match (vhash-assoc name (newest-available-packages)) - ((_ version pkgs ...) pkgs) - (#f '())))) - - (define (find-package name) - ;; Find the package NAME; NAME may contain a version number and a - ;; sub-derivation name. If the version number is not present, - ;; return the preferred newest version. - (define request name) - - (define (ensure-output p sub-drv) - (if (member sub-drv (package-outputs p)) - p - (leave (_ "~a: error: package `~a' lacks output `~a'~%") - (location->string (package-location p)) - (package-full-name p) - sub-drv))) - - (let*-values (((name sub-drv) - (match (string-rindex name #\:) - (#f (values name "out")) - (colon (values (substring name 0 colon) - (substring name (+ 1 colon)))))) - ((name version) - (package-name->name+version name))) - (match (find-best-packages-by-name name version) - ((p) - (list name (package-version p) sub-drv (ensure-output p sub-drv) - (package-transitive-propagated-inputs p))) - ((p p* ...) - (format (current-error-port) - (_ "warning: ambiguous package specification `~a'~%") - request) - (format (current-error-port) - (_ "warning: choosing ~a from ~a~%") - (package-full-name p) - (location->string (package-location p))) - (list name (package-version p) sub-drv (ensure-output p sub-drv) - (package-transitive-propagated-inputs p))) - (() - (leave (_ "~a: package not found~%") request))))) - - (define (upgradeable? name current-version current-path) - ;; Return #t if there's a version of package NAME newer than - ;; CURRENT-VERSION, or if the newest available version is equal to - ;; CURRENT-VERSION but would have an output path different than - ;; CURRENT-PATH. - (match (vhash-assoc name (newest-available-packages)) - ((_ candidate-version pkg . rest) - (case (version-compare candidate-version current-version) - ((>) #t) - ((<) #f) - ((=) (let ((candidate-path (derivation-path->output-path - (package-derivation (%store) pkg)))) - (not (string=? current-path candidate-path)))))) - (#f #f))) - - (define (ensure-default-profile) - ;; Ensure the default profile symlink and directory exist. - - ;; Create ~/.guix-profile if it doesn't exist yet. - (when (and %user-environment-directory - %current-profile - (not (false-if-exception - (lstat %user-environment-directory)))) - (symlink %current-profile %user-environment-directory)) - - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (directory-exists? %profile-directory) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (exit 1))))) - - (define (process-actions opts) - ;; Process any install/remove/upgrade action from OPTS. - - (define dry-run? (assoc-ref opts 'dry-run?)) - (define verbose? (assoc-ref opts 'verbose?)) - (define profile (assoc-ref opts 'profile)) - - (define (canonicalize-deps deps) - ;; Remove duplicate entries from DEPS, a list of propagated inputs, - ;; where each input is a name/path tuple. - (define (same? d1 d2) - (match d1 - ((_ path1) - (match d2 - ((_ path2) - (string=? path1 path2)))))) - - (delete-duplicates (map input->name+path deps) same?)) - - ;; First roll back if asked to. - (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) - (begin - (roll-back profile) - (process-actions (alist-delete 'roll-back? opts))) - (let* ((installed (manifest-packages (profile-manifest profile))) - (upgrade-regexps (filter-map (match-lambda - (('upgrade . regexp) - (make-regexp regexp)) - (_ #f)) - opts)) - (upgrade (if (null? upgrade-regexps) - '() - (let ((newest (find-newest-available-packages))) - (filter-map (match-lambda - ((name version output path _) - (and (any (cut regexp-exec <> name) - upgrade-regexps) - (upgradeable? name version path) - (find-package name))) - (_ #f)) - installed)))) - (install (append - upgrade - (filter-map (match-lambda - (('install . (? store-path?)) - #f) - (('install . package) - (find-package package)) - (_ #f)) - opts))) - (drv (filter-map (match-lambda - ((name version sub-drv - (? package? package) - (deps ...)) - (package-derivation (%store) package)) - (_ #f)) - install)) - (install* (append - (filter-map (match-lambda - (('install . (? store-path? path)) - (let-values (((name version) - (package-name->name+version - (store-path-package-name - path)))) - `(,name ,version #f ,path ()))) - (_ #f)) - opts) - (map (lambda (tuple drv) - (match tuple - ((name version sub-drv _ (deps ...)) - (let ((output-path - (derivation-path->output-path - drv sub-drv))) - `(,name ,version ,sub-drv ,output-path - ,(canonicalize-deps deps)))))) - install drv))) - (remove (filter-map (match-lambda - (('remove . package) - package) - (_ #f)) - opts)) - (packages (append install* - (fold (lambda (package result) - (match package - ((name _ ...) - (alist-delete name result)))) - (fold alist-delete installed remove) - install*)))) - - (when (equal? profile %current-profile) - (ensure-default-profile)) - - (show-what-to-build drv dry-run?) - - (or dry-run? - (and (build-derivations (%store) drv) - (let* ((prof-drv (profile-derivation (%store) packages)) - (prof (derivation-path->output-path prof-drv)) - (old-drv (profile-derivation - (%store) (manifest-packages - (profile-manifest profile)))) - (old-prof (derivation-path->output-path old-drv)) - (number (profile-number profile)) - - ;; Always use NUMBER + 1 for the new profile, - ;; possibly overwriting a "previous future - ;; generation". - (name (format #f "~a-~a-link" - profile (+ 1 number)))) - (if (string=? old-prof prof) - (when (or (pair? install) (pair? remove)) - (format (current-error-port) - (_ "nothing to be done~%"))) - (and (parameterize ((current-build-output-port - ;; Output something when Guile - ;; needs to be built. - (if (or verbose? (guile-missing?)) - (current-error-port) - (%make-void-port "w")))) - (build-derivations (%store) (list prof-drv))) - (begin - (switch-symlinks name prof) - (switch-symlinks profile name)))))))))) - - (define (process-query opts) - ;; Process any query specified by OPTS. Return #t when a query was - ;; actually processed, #f otherwise. - (let ((profile (assoc-ref opts 'profile))) - (match (assoc-ref opts 'query) - (('list-installed regexp) - (let* ((regexp (and regexp (make-regexp regexp))) - (manifest (profile-manifest profile)) - (installed (manifest-packages manifest))) - (for-each (match-lambda - ((name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - installed) - #t)) - - (('list-available regexp) - (let* ((regexp (and regexp (make-regexp regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)))) - '()))) - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) - (sort available - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2))))) - #t)) - - (('search regexp) - (let ((regexp (make-regexp regexp regexp/icase))) - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-description regexp)) - #t)) - (_ #f)))) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let ((opts (parse-options))) - (or (process-query opts) - (parameterize ((%store (open-connection))) - (with-error-handling - (parameterize ((%guile-for-build - (package-derivation (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - guile-final)))) - (process-actions opts))))))) |