From e49951eb3e1e1a8e7bad6d7471483e70b0865352 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 14 Feb 2013 04:15:25 -0500 Subject: 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. --- .gitignore | 6 +- Makefile.am | 11 +- configure.ac | 9 +- doc/guix.texi | 82 +++--- guix-build.in | 317 --------------------- guix-download.in | 164 ----------- guix-gc.in | 183 ------------ guix-import.in | 137 --------- guix-package.in | 706 ---------------------------------------------- guix/scripts/build.scm | 304 ++++++++++++++++++++ guix/scripts/download.scm | 151 ++++++++++ guix/scripts/gc.scm | 165 +++++++++++ guix/scripts/import.scm | 124 ++++++++ guix/scripts/package.scm | 693 +++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 38 ++- po/POTFILES.in | 8 +- pre-inst-env.in | 11 +- scripts/guix.in | 56 ++++ tests/guix-build.sh | 26 +- tests/guix-daemon.sh | 6 +- tests/guix-download.sh | 12 +- tests/guix-gc.sh | 24 +- tests/guix-package.sh | 56 ++-- 23 files changed, 1654 insertions(+), 1635 deletions(-) delete mode 100644 guix-build.in delete mode 100644 guix-download.in delete mode 100644 guix-gc.in delete mode 100644 guix-import.in delete mode 100644 guix-package.in create mode 100644 guix/scripts/build.scm create mode 100644 guix/scripts/download.scm create mode 100644 guix/scripts/gc.scm create mode 100644 guix/scripts/import.scm create mode 100644 guix/scripts/package.scm create mode 100644 scripts/guix.in diff --git a/.gitignore b/.gitignore index ecdaed2ef0..302e473fd8 100644 --- a/.gitignore +++ b/.gitignore @@ -34,7 +34,6 @@ config.cache /po/remove-potcdate.sin /po/stamp-po /po/guix.pot -/guix-build /tests/*.trs /INSTALL /m4/* @@ -44,12 +43,9 @@ config.cache /doc/guix.pdf /doc/stamp-vti /doc/version.texi -/guix-download /gnu/packages/bootstrap/x86_64-linux/guile-2.0.7.tar.xz /gnu/packages/bootstrap/i686-linux/guile-2.0.7.tar.xz -/guix-package /guix/config.scm -/guix-import /nix/nix-daemon/nix-daemon.cc /nix/config.h /nix/config.h.in @@ -64,7 +60,7 @@ stamp-h[0-9] /nix/scripts/list-runtime-roots /test-env /nix/nix-setuid-helper/nix-setuid-helper.cc -/guix-gc +/scripts/guix /doc/guix.aux /doc/guix.cp /doc/guix.cps diff --git a/Makefile.am b/Makefile.am index 7a1b6ad163..5932e1350a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -18,17 +18,18 @@ # along with GNU Guix. If not, see . bin_SCRIPTS = \ - guix-build \ - guix-download \ - guix-import \ - guix-package \ - guix-gc + scripts/guix nodist_noinst_SCRIPTS = \ pre-inst-env \ test-env MODULES = \ + guix/scripts/build.scm \ + guix/scripts/download.scm \ + guix/scripts/import.scm \ + guix/scripts/package.scm \ + guix/scripts/gc.scm \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ diff --git a/configure.ac b/configure.ac index a9cf17ac57..dd1f843afb 100644 --- a/configure.ac +++ b/configure.ac @@ -117,14 +117,9 @@ AC_CONFIG_FILES([Makefile po/Makefile.in guix/config.scm]) -AC_CONFIG_FILES([guix-build - guix-download - guix-import - guix-package - guix-gc +AC_CONFIG_FILES([scripts/guix pre-inst-env test-env], - [chmod +x guix-build guix-download guix-import guix-package guix-gc \ - pre-inst-env test-env]) + [chmod +x scripts/guix pre-inst-env test-env]) AC_OUTPUT diff --git a/doc/guix.texi b/doc/guix.texi index 80149326c1..f84b37686a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13,9 +13,9 @@ @dircategory Package management @direntry * guix: (guix). Guix, the functional package manager. -* guix-package: (guix)Invoking guix-package +* guix package: (guix)Invoking guix package Managing packages with Guix. -* guix-build: (guix)Invoking guix-build +* guix build: (guix)Invoking guix build Building packages with Guix. @end direntry @@ -196,7 +196,7 @@ are all performed by a specialized process, the @dfn{Guix daemon}, on behalf of clients. Only the daemon may access the store and its associated database. Thus, any operation that manipulates the store goes through the daemon. For instance, command-line tools such as -@command{guix-package} and @command{guix-build} communicate with the +@command{guix package} and @command{guix build} communicate with the daemon (@i{via} remote procedure calls) to instruct it what to do. In a standard multi-user setup, Guix and its daemon---the @@ -302,8 +302,8 @@ Use @var{n} CPU cores to build each derivation; @code{0} means as many as available. The default value is @code{1}, but it may be overridden by clients, such -as the @code{--cores} option of @command{guix-build} (@pxref{Invoking -guix-build}). +as the @code{--cores} option of @command{guix build} (@pxref{Invoking +guix build}). The effect is to define the @code{NIX_BUILD_CORES} environment variable in the build process, which can then use it to exploit internal @@ -319,7 +319,7 @@ Produce debugging output. This is useful to debug daemon start-up issues, but then it may be overridden by clients, for example the @code{--verbosity} option of -@command{guix-build} (@pxref{Invoking guix-build}). +@command{guix build} (@pxref{Invoking guix build}). @item --chroot-directory=@var{dir} Add @var{dir} to the build chroot. @@ -384,8 +384,8 @@ management tools it provides. @menu * Features:: How Guix will make your life brighter. -* Invoking guix-package:: Package installation, removal, etc. -* Invoking guix-gc:: Running the garbage collector. +* Invoking guix package:: Package installation, removal, etc. +* Invoking guix gc:: Running the garbage collector. @end menu @node Features @@ -408,14 +408,14 @@ simply continues to point to @file{/nix/store/@dots{}-gcc-4.8.0/bin/gcc}---i.e., both versions of GCC coexist on the same system without any interference. -The @command{guix-package} command is the central tool to manage -packages (@pxref{Invoking guix-package}). It operates on those per-user +The @command{guix package} command is the central tool to manage +packages (@pxref{Invoking guix package}). It operates on those per-user profiles, and can be used @emph{with normal user privileges}. The command provides the obvious install, remove, and upgrade operations. Each invocation is actually a @emph{transaction}: either the specified operation succeeds, or nothing happens. Thus, if the -@command{guix-package} process is terminated during the transaction, +@command{guix package} process is terminated during the transaction, or if a power outage occurs during the transaction, then the user's profile remains in its previous state, and remains usable. @@ -427,7 +427,7 @@ of their profile, which was known to work well. All those packages in the package store may be @emph{garbage-collected}. Guix can determine which packages are still referenced by the user profiles, and remove those that are provably no longer referenced -(@pxref{Invoking guix-gc}). Users may also explicitly remove old +(@pxref{Invoking guix gc}). Users may also explicitly remove old generations of their profile so that the packages they refer to can be collected. @@ -447,17 +447,17 @@ details.}. When a pre-built binary for a @file{/nix/store} path is available from an external source, Guix just downloads it; otherwise, it builds the package from source, locally. -@node Invoking guix-package -@section Invoking @command{guix-package} +@node Invoking guix package +@section Invoking @command{guix package} -The @command{guix-package} command is the tool that allows users to +The @command{guix package} command is the tool that allows users to install, upgrade, and remove packages, as well as rolling back to previous configurations. It operates only on the user's own profile, and works with normal user privileges (@pxref{Features}). Its syntax is: @example -guix-package @var{options} +guix package @var{options} @end example Primarily, @var{options} specifies the operations to be performed during @@ -473,13 +473,13 @@ variable, and so on. In a multi-user setup, user profiles must be stored in a place registered as a @dfn{garbage-collector root}, which -@file{$HOME/.guix-profile} points to (@pxref{Invoking guix-gc}). That +@file{$HOME/.guix-profile} points to (@pxref{Invoking guix gc}). That directory is normally @code{@var{localstatedir}/profiles/per-user/@var{user}}, where @var{localstatedir} is the value passed to @code{configure} as @code{--localstatedir}, and @var{user} is the user name. It must be created by @code{root}, with @var{user} as the owner. When it does not -exist, @command{guix-package} emits an error about it. +exist, @command{guix package} emits an error about it. The @var{options} can be among the following: @@ -548,7 +548,7 @@ useful to distribution developers. @end table -In addition to these actions @command{guix-package} supports the +In addition to these actions @command{guix package} supports the following options to query the current state of a profile, or the availability of packages: @@ -565,7 +565,7 @@ This allows specific fields to be extracted using the @command{recsel} command, for instance: @example -$ guix-package -s malloc | recsel -p name,version +$ guix package -s malloc | recsel -p name,version name: glibc version: 2.17 @@ -599,22 +599,22 @@ source location of its definition. @end table -@node Invoking guix-gc -@section Invoking @command{guix-gc} +@node Invoking guix gc +@section Invoking @command{guix gc} @cindex garbage collector Packages that are installed but not used may be @dfn{garbage-collected}. -The @command{guix-gc} command allows users to explicitly run the garbage +The @command{guix gc} command allows users to explicitly run the garbage collector to reclaim space from the @file{/nix/store} directory. The garbage collector has a set of known @dfn{roots}: any file under @file{/nix/store} reachable from a root is considered @dfn{live} and cannot be deleted; any other file is considered @dfn{dead} and may be deleted. The set of garbage collector roots includes default user -profiles, and may be augmented with @command{guix-build --root}, for -example (@pxref{Invoking guix-build}). +profiles, and may be augmented with @command{guix build --root}, for +example (@pxref{Invoking guix build}). -The @command{guix-gc} command has three modes of operation: it can be +The @command{guix gc} command has three modes of operation: it can be used to garbage-collect any dead files (the default), to delete specific files (the @code{--delete} option), or to print garbage-collector information. The available options are listed below: @@ -737,7 +737,7 @@ The @code{sha256} field specifies the expected SHA256 hash of the file being downloaded. It is mandatory, and allows Guix to check the integrity of the file. The @code{(base32 @dots{})} form introduces the base32 representation of the hash. A convenient way to obtain this -information is with the @code{guix-download} tool. +information is with the @code{guix download} tool. @item @cindex GNU Build System @@ -795,9 +795,9 @@ Guile process launched by the daemon (@pxref{Derivations}). Once a package definition is in place@footnote{Simple package definitions like the one above may be automatically converted from the -Nixpkgs distribution using the @command{guix-import} command.}, the -package may actually be built using the @code{guix-build} command-line -tool (@pxref{Invoking guix-build}). +Nixpkgs distribution using the @command{guix import} command.}, the +package may actually be built using the @code{guix build} command-line +tool (@pxref{Invoking guix build}). Behind the scenes, a derivation corresponding to the @code{} object is first computed by the @code{package-derivation} procedure. @@ -1015,22 +1015,22 @@ space. @chapter Utilities @menu -* Invoking guix-build:: Building packages from the command line. +* Invoking guix build:: Building packages from the command line. @end menu -@node Invoking guix-build -@section Invoking @command{guix-build} +@node Invoking guix build +@section Invoking @command{guix build} -The @command{guix-build} command builds packages or derivations and +The @command{guix build} command builds packages or derivations and their dependencies, and prints the resulting store paths. Note that it does not modify the user's profile---this is the job of the -@command{guix-package} command (@pxref{Invoking guix-package}). Thus, +@command{guix package} command (@pxref{Invoking guix package}). Thus, it is mainly useful for distribution developers. The general syntax is: @example -guix-build @var{options} @var{package-or-derivation}@dots{} +guix build @var{options} @var{package-or-derivation}@dots{} @end example @var{package-or-derivation} may be either the name of a package found in @@ -1058,7 +1058,7 @@ version 1.8 of Guile. Build the packages' source derivations, rather than the packages themselves. -For instance, @code{guix-build -S gcc} returns something like +For instance, @code{guix build -S gcc} returns something like @file{/nix/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball. @item --system=@var{system} @@ -1106,7 +1106,7 @@ may be helpful when debugging setup issues with the build daemon. @end table -Behind the scenes, @command{guix-build} is essentially an interface to +Behind the scenes, @command{guix build} is essentially an interface to the @code{package-derivation} procedure of the @code{(guix packages)} module, and to the @code{build-derivations} procedure of the @code{(guix store)} module. @@ -1121,11 +1121,11 @@ Guix comes with a distribution of free software@footnote{The term users of that software}.} that form the basis of the GNU system. This includes core GNU packages such as GNU libc, GCC, and Binutils, as well as many GNU and non-GNU applications. The complete list of available -packages can be seen by running @command{guix-package} (@pxref{Invoking -guix-package}): +packages can be seen by running @command{guix package} (@pxref{Invoking +guix package}): @example -guix-package --list-available +guix package --list-available @end example The package definitions of the distribution may are provided by Guile diff --git a/guix-build.in b/guix-build.in deleted file mode 100644 index 35ddb00861..0000000000 --- a/guix-build.in +++ /dev/null @@ -1,317 +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-build)) '\'guix-build')' -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 -;;; Copyright © 2013 Mark H Weaver -;;; -;;; 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 . - -(define-module (guix-build) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix derivations) - #:use-module (guix packages) - #:use-module (guix utils) - #:use-module (ice-9 format) - #:use-module (ice-9 match) - #: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) - #:autoload (gnu packages) (find-packages-by-name - find-newest-available-packages) - #:export (guix-build)) - -(define %store - (make-parameter #f)) - -(define (derivations-from-package-expressions exp system source?) - "Eval EXP and return the corresponding derivation path for SYSTEM. -When SOURCE? is true, return the derivations of the package sources." - (let ((p (eval exp (current-module)))) - (if (package? p) - (if source? - (let ((source (package-source p)) - (loc (package-location p))) - (if source - (package-source-derivation (%store) source) - (leave (_ "~a: error: package `~a' has no source~%") - (location->string loc) (package-name p)))) - (package-derivation (%store) p system)) - (leave (_ "expression `~s' does not evaluate to a package~%") - exp)))) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((system . ,(%current-system)) - (substitutes? . #t) - (verbosity . 0))) - -(define (show-help) - (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION... -Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) - (display (_ " - -e, --expression=EXPR build the package EXPR evaluates to")) - (display (_ " - -S, --source build the packages' source derivations")) - (display (_ " - -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) - (display (_ " - -d, --derivations return the derivation paths of the given packages")) - (display (_ " - -K, --keep-failed keep build tree of failed builds")) - (display (_ " - -n, --dry-run do not build the derivations")) - (display (_ " - --no-substitutes build instead of resorting to pre-built substitutes")) - (display (_ " - -c, --cores=N allow the use of up to N CPU cores for the build")) - (display (_ " - -r, --root=FILE make FILE a symlink to the result, and register it - as a garbage collector root")) - (display (_ " - --verbosity=LEVEL use the given verbosity LEVEL")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specifications 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-build"))) - - (option '(#\S "source") #f #f - (lambda (opt name arg result) - (alist-cons 'source? #t result))) - (option '(#\s "system") #t #f - (lambda (opt name arg result) - (alist-cons 'system arg - (alist-delete 'system result eq?)))) - (option '(#\d "derivations") #f #f - (lambda (opt name arg result) - (alist-cons 'derivations-only? #t result))) - (option '(#\e "expression") #t #f - (lambda (opt name arg result) - (alist-cons 'expression - (call-with-input-string arg read) - result))) - (option '(#\K "keep-failed") #f #f - (lambda (opt name arg result) - (alist-cons 'keep-failed? #t result))) - (option '(#\c "cores") #t #f - (lambda (opt name arg result) - (let ((c (false-if-exception (string->number arg)))) - (if c - (alist-cons 'cores c result) - (leave (_ "~a: not a number~%") arg))))) - (option '(#\n "dry-run") #f #f - (lambda (opt name arg result) - (alist-cons 'dry-run? #t result))) - (option '("no-substitutes") #f #f - (lambda (opt name arg result) - (alist-cons 'substitutes? #f - (alist-delete 'substitutes? result)))) - (option '(#\r "root") #t #f - (lambda (opt name arg result) - (alist-cons 'gc-root arg result))) - (option '("verbosity") #t #f - (lambda (opt name arg result) - (let ((level (string->number arg))) - (alist-cons 'verbosity level - (alist-delete 'verbosity result))))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-build . 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) - (alist-cons 'argument arg result)) - %default-options)) - - (define (register-root paths root) - ;; Register ROOT as an indirect GC root for all of PATHS. - (let* ((root (string-append (canonicalize-path (dirname root)) - "/" root))) - (catch 'system-error - (lambda () - (match paths - ((path) - (symlink path root) - (add-indirect-root (%store) root)) - ((paths ...) - (fold (lambda (path count) - (let ((root (string-append root "-" (number->string count)))) - (symlink path root) - (add-indirect-root (%store) root)) - (+ 1 count)) - 0 - paths)))) - (lambda args - (format (current-error-port) - (_ "failed to create GC root `~a': ~a~%") - root (strerror (system-error-errno args))) - (exit 1))))) - - (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 request) - ;; Return a package matching REQUEST. REQUEST may be a package - ;; name, or a package name followed by a hyphen and a version - ;; number. If the version number is not present, return the - ;; preferred newest version. - (let-values (((name version) - (package-name->name+version request))) - (match (find-best-packages-by-name name version) - ((p) ; one match - p) - ((p x ...) ; several matches - (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))) - p) - (_ ; no matches - (if version - (leave (_ "~A: package not found for version ~a~%") - name version) - (leave (_ "~A: unknown package~%") name)))))) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (with-error-handling - (let ((opts (parse-options))) - (parameterize ((%store (open-connection))) - (let* ((src? (assoc-ref opts 'source?)) - (sys (assoc-ref opts 'system)) - (drv (filter-map (match-lambda - (('expression . exp) - (derivations-from-package-expressions exp sys - src?)) - (('argument . (? derivation-path? drv)) - drv) - (('argument . (? string? x)) - (let ((p (find-package x))) - (if src? - (let ((s (package-source p))) - (package-source-derivation - (%store) s)) - (package-derivation (%store) p sys)))) - (_ #f)) - opts)) - (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 (cut valid-path? (%store) <>) - derivation-path->output-path) - drv) - (map derivation-input-path req)))) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - (if (assoc-ref opts '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*)) - - ;; TODO: Add more options. - (set-build-options (%store) - #:keep-failed? (assoc-ref opts 'keep-failed?) - #:build-cores (or (assoc-ref opts 'cores) 0) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:verbosity (assoc-ref opts 'verbosity)) - - (if (assoc-ref opts 'derivations-only?) - (begin - (format #t "~{~a~%~}" drv) - (for-each (cut register-root <> <>) - (map list drv) roots)) - (or (assoc-ref opts 'dry-run?) - (and (build-derivations (%store) drv) - (for-each (lambda (d) - (let ((drv (call-with-input-file d - read-derivation))) - (format #t "~{~a~%~}" - (map (match-lambda - ((out-name . out) - (derivation-path->output-path - d out-name))) - (derivation-outputs drv))))) - drv) - (for-each (cut register-root <> <>) - (map (lambda (drv) - (map cdr - (derivation-path->output-paths drv))) - drv) - roots))))))))) diff --git a/guix-download.in b/guix-download.in deleted file mode 100644 index ea62b09a7b..0000000000 --- a/guix-download.in +++ /dev/null @@ -1,164 +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-download)) '\'guix-download')' -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 -;;; -;;; 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 . - -(define-module (guix-download) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (guix utils) - #:use-module (guix base32) - #:use-module ((guix download) #:select (%mirrors)) - #:use-module (guix build download) - #:use-module (web uri) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:export (guix-download)) - -(define (call-with-temporary-output-file proc) - (let* ((template (string-copy "guix-download.XXXXXX")) - (out (mkstemp! template))) - (dynamic-wind - (lambda () - #t) - (lambda () - (proc template out)) - (lambda () - (false-if-exception (delete-file template)))))) - -(define (fetch-and-store store fetch name) - "Call FETCH for URI, and pass it the name of a file to write to; eventually, -copy data from that port to STORE, under NAME. Return the resulting -store path." - (call-with-temporary-output-file - (lambda (temp port) - (let ((result - (parameterize ((current-output-port (current-error-port))) - (fetch temp)))) - (close port) - (and result - (add-to-store store name #f "sha256" temp)))))) - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((format . ,bytevector->nix-base32-string))) - -(define (show-help) - (display (_ "Usage: guix-download [OPTION]... URL -Download the file at URL, add it to the store, and print its store path -and the hash of its contents.\n")) - (format #t (_ " - -f, --format=FMT write the hash in the given format (default: `nix-base32')")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define %options - ;; Specifications of the command-line options. - (list (option '(#\f "format") #t #f - (lambda (opt name arg result) - (define fmt-proc - (match arg - ("nix-base32" - bytevector->nix-base32-string) - ("base32" - bytevector->base32-string) - ((or "base16" "hex" "hexadecimal") - bytevector->base16-string) - (x - (format (current-error-port) - "unsupported hash format: ~a~%" arg)))) - - (alist-cons 'format fmt-proc - (alist-delete 'format result)))) - - (option '(#\h "help") #f #f - (lambda args - (show-help) - (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix-download"))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-download . 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) - (alist-cons 'argument arg result)) - %default-options)) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let* ((opts (parse-options)) - (store (open-connection)) - (arg (assq-ref opts 'argument)) - (uri (or (string->uri arg) - (leave (_ "guix-download: ~a: failed to parse URI~%") - arg))) - (path (case (uri-scheme uri) - ((file) - (add-to-store store (basename (uri-path uri)) - #f "sha256" (uri-path uri))) - (else - (fetch-and-store store - (cut url-fetch arg <> - #:mirrors %mirrors) - (basename (uri-path uri)))))) - (hash (call-with-input-file - (or path - (leave (_ "guix-download: ~a: download failed~%") - arg)) - (compose sha256 get-bytevector-all))) - (fmt (assq-ref opts 'format))) - (format #t "~a~%~a~%" path (fmt hash)) - #t)) diff --git a/guix-gc.in b/guix-gc.in deleted file mode 100644 index 1a4a5413d9..0000000000 --- a/guix-gc.in +++ /dev/null @@ -1,183 +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-gc)) '\'guix-gc')' -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 -;;; -;;; 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 . - -(define-module (guix-gc) - #:use-module (guix ui) - #:use-module (guix store) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:export (guix-gc)) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - ;; Alist of default option values. - `((action . collect-garbage))) - -(define (show-help) - (display (_ "Usage: guix-gc [OPTION]... PATHS... -Invoke the garbage collector.\n")) - (display (_ " - -C, --collect-garbage[=MIN] - collect at least MIN bytes of garbage")) - (display (_ " - -d, --delete attempt to delete PATHS")) - (display (_ " - --list-dead list dead paths")) - (display (_ " - --list-live list live paths")) - (newline) - (display (_ " - -h, --help display this help and exit")) - (display (_ " - -V, --version display version information and exit")) - (newline) - (show-bug-report-information)) - -(define (size->number str) - "Convert STR, a storage measurement representation such as \"1024\" or -\"1MiB\", to a number of bytes. Raise an error if STR could not be -interpreted." - (define unit-pos - (string-rindex str char-set:digit)) - - (define unit - (and unit-pos (substring str (+ 1 unit-pos)))) - - (let* ((numstr (if unit-pos - (substring str 0 (+ 1 unit-pos)) - str)) - (num (string->number numstr))) - (if num - (* num - (match unit - ("KiB" (expt 2 10)) - ("MiB" (expt 2 20)) - ("GiB" (expt 2 30)) - ("TiB" (expt 2 40)) - ("KB" (expt 10 3)) - ("MB" (expt 10 6)) - ("GB" (expt 10 9)) - ("TB" (expt 10 12)) - ("" 1) - (_ - (format (current-error-port) (_ "error: unknown unit: ~a~%") - unit) - (exit 1)))) - (begin - (format (current-error-port) - (_ "error: invalid number: ~a") numstr) - (exit 1))))) - -(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-gc"))) - - (option '(#\C "collect-garbage") #f #t - (lambda (opt name arg result) - (let ((result (alist-cons 'action 'collect-garbage - (alist-delete 'action result)))) - (match arg - ((? string?) - (let ((amount (size->number arg))) - (if arg - (alist-cons 'min-freed amount result) - (begin - (format (current-error-port) - (_ "error: invalid amount of storage: ~a~%") - arg) - (exit 1))))) - (#f result))))) - (option '(#\d "delete") #f #f - (lambda (opt name arg result) - (alist-cons 'action 'delete - (alist-delete 'action result)))) - (option '("list-dead") #f #f - (lambda (opt name arg result) - (alist-cons 'action 'list-dead - (alist-delete 'action result)))) - (option '("list-live") #f #f - (lambda (opt name arg result) - (alist-cons 'action 'list-live - (alist-delete 'action result)))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-gc . 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) - (alist-cons 'argument arg result)) - %default-options)) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (with-error-handling - (let ((opts (parse-options)) - (store (open-connection))) - (case (assoc-ref opts 'action) - ((collect-garbage) - (let ((min-freed (assoc-ref opts 'min-freed))) - (if min-freed - (collect-garbage store min-freed) - (collect-garbage store)))) - ((delete) - (let ((paths (filter-map (match-lambda - (('argument . arg) arg) - (_ #f)) - opts))) - (delete-paths store paths))) - ((list-dead) - (for-each (cut simple-format #t "~a~%" <>) - (dead-paths store))) - ((list-live) - (for-each (cut simple-format #t "~a~%" <>) - (live-paths store))))))) diff --git a/guix-import.in b/guix-import.in deleted file mode 100644 index 97619a9a59..0000000000 --- a/guix-import.in +++ /dev/null @@ -1,137 +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-import)) '\'guix-import')' -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 -;;; -;;; 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 . - -(define-module (guix-import) - #:use-module (guix ui) - #:use-module (guix snix) - #:use-module (guix utils) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) - #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) - #:export (guix-import)) - - -;;; -;;; Helper. -;;; - -(define (newline-rewriting-port output) - "Return an output port that rewrites strings containing the \\n escape -to an actual newline. This works around the behavior of `pretty-print' -and `write', which output these as \\n instead of actual newlines, -whereas we want the `description' field to contain actual newlines -rather than \\n." - (define (write-string str) - (let loop ((chars (string->list str))) - (match chars - (() - #t) - ((#\\ #\n rest ...) - (newline output) - (loop rest)) - ((chr rest ...) - (write-char chr output) - (loop rest))))) - - (make-soft-port (vector (cut write-char <>) - write-string - (lambda _ #t) ; flush - #f - (lambda _ #t) ; close - #f) - "w")) - - -;;; -;;; Command-line options. -;;; - -(define %default-options - '()) - -(define (show-help) - (display (_ "Usage: guix-import NIXPKGS ATTRIBUTE -Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) - (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-import"))))) - - -;;; -;;; Entry point. -;;; - -(define (guix-import . 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) - (alist-cons 'argument arg result)) - %default-options)) - - (install-locale) - (textdomain "guix") - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (let* ((opts (parse-options)) - (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) - (reverse opts)))) - (match args - ((nixpkgs attribute) - (let-values (((expr loc) - (nixpkgs->guix-package nixpkgs attribute))) - (format #t ";; converted from ~a:~a~%~%" - (location-file loc) (location-line loc)) - (pretty-print expr (newline-rewriting-port (current-output-port))))) - (_ - (leave (_ "wrong number of arguments~%")))))) 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 -;;; Copyright © 2013 Nikita Karetnikov -;;; Copyright © 2013 Mark H Weaver -;;; -;;; 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 . - -(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 (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry)) - (#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) - (stringname+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) - (stringrecutils <> (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))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm new file mode 100644 index 0000000000..bad04418f1 --- /dev/null +++ b/guix/scripts/build.scm @@ -0,0 +1,304 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Mark H Weaver +;;; +;;; 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 . + +(define-module (guix scripts build) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #: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) + #:autoload (gnu packages) (find-packages-by-name + find-newest-available-packages) + #:export (guix-build)) + +(define %store + (make-parameter #f)) + +(define (derivations-from-package-expressions exp system source?) + "Eval EXP and return the corresponding derivation path for SYSTEM. +When SOURCE? is true, return the derivations of the package sources." + (let ((p (eval exp (current-module)))) + (if (package? p) + (if source? + (let ((source (package-source p)) + (loc (package-location p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "~a: error: package `~a' has no source~%") + (location->string loc) (package-name p)))) + (package-derivation (%store) p system)) + (leave (_ "expression `~s' does not evaluate to a package~%") + exp)))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((system . ,(%current-system)) + (substitutes? . #t) + (verbosity . 0))) + +(define (show-help) + (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... +Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) + (display (_ " + -e, --expression=EXPR build the package EXPR evaluates to")) + (display (_ " + -S, --source build the packages' source derivations")) + (display (_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -d, --derivations return the derivation paths of the given packages")) + (display (_ " + -K, --keep-failed keep build tree of failed builds")) + (display (_ " + -n, --dry-run do not build the derivations")) + (display (_ " + --no-substitutes build instead of resorting to pre-built substitutes")) + (display (_ " + -c, --cores=N allow the use of up to N CPU cores for the build")) + (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " + --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications 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-build"))) + + (option '(#\S "source") #f #f + (lambda (opt name arg result) + (alist-cons 'source? #t result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + (option '(#\d "derivations") #f #f + (lambda (opt name arg result) + (alist-cons 'derivations-only? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression + (call-with-input-string arg read) + result))) + (option '(#\K "keep-failed") #f #f + (lambda (opt name arg result) + (alist-cons 'keep-failed? #t result))) + (option '(#\c "cores") #t #f + (lambda (opt name arg result) + (let ((c (false-if-exception (string->number arg)))) + (if c + (alist-cons 'cores c result) + (leave (_ "~a: not a number~%") arg))))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '("no-substitutes") #f #f + (lambda (opt name arg result) + (alist-cons 'substitutes? #f + (alist-delete 'substitutes? result)))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) + (option '("verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-build . 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) + (alist-cons 'argument arg result)) + %default-options)) + + (define (register-root paths root) + ;; Register ROOT as an indirect GC root for all of PATHS. + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (match paths + ((path) + (symlink path root) + (add-indirect-root (%store) root)) + ((paths ...) + (fold (lambda (path count) + (let ((root (string-append root "-" (number->string count)))) + (symlink path root) + (add-indirect-root (%store) root)) + (+ 1 count)) + 0 + paths)))) + (lambda args + (format (current-error-port) + (_ "failed to create GC root `~a': ~a~%") + root (strerror (system-error-errno args))) + (exit 1))))) + + (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 request) + ;; Return a package matching REQUEST. REQUEST may be a package + ;; name, or a package name followed by a hyphen and a version + ;; number. If the version number is not present, return the + ;; preferred newest version. + (let-values (((name version) + (package-name->name+version request))) + (match (find-best-packages-by-name name version) + ((p) ; one match + p) + ((p x ...) ; several matches + (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))) + p) + (_ ; no matches + (if version + (leave (_ "~A: package not found for version ~a~%") + name version) + (leave (_ "~A: unknown package~%") name)))))) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (with-error-handling + (let ((opts (parse-options))) + (parameterize ((%store (open-connection))) + (let* ((src? (assoc-ref opts 'source?)) + (sys (assoc-ref opts 'system)) + (drv (filter-map (match-lambda + (('expression . exp) + (derivations-from-package-expressions exp sys + src?)) + (('argument . (? derivation-path? drv)) + drv) + (('argument . (? string? x)) + (let ((p (find-package x))) + (if src? + (let ((s (package-source p))) + (package-source-derivation + (%store) s)) + (package-derivation (%store) p sys)))) + (_ #f)) + opts)) + (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 (cut valid-path? (%store) <>) + derivation-path->output-path) + drv) + (map derivation-input-path req)))) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + (if (assoc-ref opts '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*)) + + ;; TODO: Add more options. + (set-build-options (%store) + #:keep-failed? (assoc-ref opts 'keep-failed?) + #:build-cores (or (assoc-ref opts 'cores) 0) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity (assoc-ref opts 'verbosity)) + + (if (assoc-ref opts 'derivations-only?) + (begin + (format #t "~{~a~%~}" drv) + (for-each (cut register-root <> <>) + (map list drv) roots)) + (or (assoc-ref opts 'dry-run?) + (and (build-derivations (%store) drv) + (for-each (lambda (d) + (let ((drv (call-with-input-file d + read-derivation))) + (format #t "~{~a~%~}" + (map (match-lambda + ((out-name . out) + (derivation-path->output-path + d out-name))) + (derivation-outputs drv))))) + drv) + (for-each (cut register-root <> <>) + (map (lambda (drv) + (map cdr + (derivation-path->output-paths drv))) + drv) + roots))))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm new file mode 100644 index 0000000000..1098e6714b --- /dev/null +++ b/guix/scripts/download.scm @@ -0,0 +1,151 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts download) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module ((guix download) #:select (%mirrors)) + #:use-module (guix build download) + #:use-module (web uri) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (guix-download)) + +(define (call-with-temporary-output-file proc) + (let* ((template (string-copy "guix-download.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (delete-file template)))))) + +(define (fetch-and-store store fetch name) + "Call FETCH for URI, and pass it the name of a file to write to; eventually, +copy data from that port to STORE, under NAME. Return the resulting +store path." + (call-with-temporary-output-file + (lambda (temp port) + (let ((result + (parameterize ((current-output-port (current-error-port))) + (fetch temp)))) + (close port) + (and result + (add-to-store store name #f "sha256" temp)))))) + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((format . ,bytevector->nix-base32-string))) + +(define (show-help) + (display (_ "Usage: guix download [OPTION]... URL +Download the file at URL, add it to the store, and print its store path +and the hash of its contents.\n")) + (format #t (_ " + -f, --format=FMT write the hash in the given format (default: `nix-base32')")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (define fmt-proc + (match arg + ("nix-base32" + bytevector->nix-base32-string) + ("base32" + bytevector->base32-string) + ((or "base16" "hex" "hexadecimal") + bytevector->base16-string) + (x + (format (current-error-port) + "unsupported hash format: ~a~%" arg)))) + + (alist-cons 'format fmt-proc + (alist-delete 'format result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix-download"))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-download . 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) + (alist-cons 'argument arg result)) + %default-options)) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (store (open-connection)) + (arg (assq-ref opts 'argument)) + (uri (or (string->uri arg) + (leave (_ "guix-download: ~a: failed to parse URI~%") + arg))) + (path (case (uri-scheme uri) + ((file) + (add-to-store store (basename (uri-path uri)) + #f "sha256" (uri-path uri))) + (else + (fetch-and-store store + (cut url-fetch arg <> + #:mirrors %mirrors) + (basename (uri-path uri)))))) + (hash (call-with-input-file + (or path + (leave (_ "guix-download: ~a: download failed~%") + arg)) + (compose sha256 get-bytevector-all))) + (fmt (assq-ref opts 'format))) + (format #t "~a~%~a~%" path (fmt hash)) + #t)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm new file mode 100644 index 0000000000..8e2587186e --- /dev/null +++ b/guix/scripts/gc.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts gc) + #:use-module (guix ui) + #:use-module (guix store) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:export (guix-gc)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((action . collect-garbage))) + +(define (show-help) + (display (_ "Usage: guix gc [OPTION]... PATHS... +Invoke the garbage collector.\n")) + (display (_ " + -C, --collect-garbage[=MIN] + collect at least MIN bytes of garbage")) + (display (_ " + -d, --delete attempt to delete PATHS")) + (display (_ " + --list-dead list dead paths")) + (display (_ " + --list-live list live paths")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (size->number str) + "Convert STR, a storage measurement representation such as \"1024\" or +\"1MiB\", to a number of bytes. Raise an error if STR could not be +interpreted." + (define unit-pos + (string-rindex str char-set:digit)) + + (define unit + (and unit-pos (substring str (+ 1 unit-pos)))) + + (let* ((numstr (if unit-pos + (substring str 0 (+ 1 unit-pos)) + str)) + (num (string->number numstr))) + (if num + (* num + (match unit + ("KiB" (expt 2 10)) + ("MiB" (expt 2 20)) + ("GiB" (expt 2 30)) + ("TiB" (expt 2 40)) + ("KB" (expt 10 3)) + ("MB" (expt 10 6)) + ("GB" (expt 10 9)) + ("TB" (expt 10 12)) + ("" 1) + (_ + (format (current-error-port) (_ "error: unknown unit: ~a~%") + unit) + (exit 1)))) + (begin + (format (current-error-port) + (_ "error: invalid number: ~a") numstr) + (exit 1))))) + +(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-gc"))) + + (option '(#\C "collect-garbage") #f #t + (lambda (opt name arg result) + (let ((result (alist-cons 'action 'collect-garbage + (alist-delete 'action result)))) + (match arg + ((? string?) + (let ((amount (size->number arg))) + (if arg + (alist-cons 'min-freed amount result) + (begin + (format (current-error-port) + (_ "error: invalid amount of storage: ~a~%") + arg) + (exit 1))))) + (#f result))))) + (option '(#\d "delete") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'delete + (alist-delete 'action result)))) + (option '("list-dead") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-dead + (alist-delete 'action result)))) + (option '("list-live") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-live + (alist-delete 'action result)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-gc . 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) + (alist-cons 'argument arg result)) + %default-options)) + + (with-error-handling + (let ((opts (parse-options)) + (store (open-connection))) + (case (assoc-ref opts 'action) + ((collect-garbage) + (let ((min-freed (assoc-ref opts 'min-freed))) + (if min-freed + (collect-garbage store min-freed) + (collect-garbage store)))) + ((delete) + (let ((paths (filter-map (match-lambda + (('argument . arg) arg) + (_ #f)) + opts))) + (delete-paths store paths))) + ((list-dead) + (for-each (cut simple-format #t "~a~%" <>) + (dead-paths store))) + ((list-live) + (for-each (cut simple-format #t "~a~%" <>) + (live-paths store))))))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm new file mode 100644 index 0000000000..0bc6926c66 --- /dev/null +++ b/guix/scripts/import.scm @@ -0,0 +1,124 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix scripts import) + #:use-module (guix ui) + #:use-module (guix snix) + #:use-module (guix utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:export (guix-import)) + + +;;; +;;; Helper. +;;; + +(define (newline-rewriting-port output) + "Return an output port that rewrites strings containing the \\n escape +to an actual newline. This works around the behavior of `pretty-print' +and `write', which output these as \\n instead of actual newlines, +whereas we want the `description' field to contain actual newlines +rather than \\n." + (define (write-string str) + (let loop ((chars (string->list str))) + (match chars + (() + #t) + ((#\\ #\n rest ...) + (newline output) + (loop rest)) + ((chr rest ...) + (write-char chr output) + (loop rest))))) + + (make-soft-port (vector (cut write-char <>) + write-string + (lambda _ #t) ; flush + #f + (lambda _ #t) ; close + #f) + "w")) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import NIXPKGS ATTRIBUTE +Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) + (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-import"))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-import . 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) + (alist-cons 'argument arg result)) + %default-options)) + + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((nixpkgs attribute) + (let-values (((expr loc) + (nixpkgs->guix-package nixpkgs attribute))) + (format #t ";; converted from ~a:~a~%~%" + (location-file loc) (location-line loc)) + (pretty-print expr (newline-rewriting-port (current-output-port))))) + (_ + (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm new file mode 100644 index 0000000000..4935837d33 --- /dev/null +++ b/guix/scripts/package.scm @@ -0,0 +1,693 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2013 Mark H Weaver +;;; +;;; 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 . + +(define-module (guix scripts 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 (file-system-fold enter? leaf down up skip error #f name lstat) + (lambda (files) + (sort files entry)) + (#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) + (stringname+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) + (stringrecutils <> (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))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 4aa93de3b4..644a3070f6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +31,7 @@ #:export (_ N_ install-locale + initialize-guix leave show-version-and-exit show-bug-report-information @@ -38,7 +40,9 @@ location->string fill-paragraph string->recutils - package->recutils)) + package->recutils + run-guix-command + guix-main)) ;;; Commentary: ;;; @@ -62,6 +66,12 @@ (_ "warning: failed to install locale: ~a~%") (strerror (system-error-errno args)))))) +(define (initialize-guix) + (install-locale) + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF)) + (define-syntax-rule (leave fmt args ...) "Format FMT and ARGS to the error port and exit." (begin @@ -210,4 +220,30 @@ WIDTH columns." (and=> (package-description p) description->recutils)) (newline port)) +(define (show-guix-usage) + ;; TODO: Dynamically generate a summary of available commands. + (format (current-error-port) + (_ "Usage: guix COMMAND ARGS...~%"))) + +(define (run-guix-command command . args) + ;; TODO: Gracefully report errors + (let* ((module (resolve-interface `(guix scripts ,command))) + (command-main (module-ref module + (symbol-append 'guix- command)))) + (apply command-main args))) + +(define (guix-main arg0 . args) + (initialize-guix) + (let () + (define (option? str) (string-prefix? "-" str)) + (match args + (() (show-guix-usage) (exit 1)) + (("--help") (show-guix-usage)) + (("--version") (show-version-and-exit "guix")) + (((? option? arg1) args ...) (show-guix-usage) (exit 1)) + ((command args ...) + (apply run-guix-command + (string->symbol command) + args))))) + ;;; ui.scm ends here diff --git a/po/POTFILES.in b/po/POTFILES.in index 049a1c707e..5c0f131c06 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -4,8 +4,8 @@ gnu/packages/base.scm gnu/packages/guile.scm gnu/packages/lout.scm gnu/packages/recutils.scm +guix/scripts/build.scm +guix/scripts/download.scm +guix/scripts/package.scm +guix/scripts/gc.scm guix/ui.scm -guix-build.in -guix-download.in -guix-package.in -guix-gc.in diff --git a/pre-inst-env.in b/pre-inst-env.in index 1dc63cd90c..4e079c8d41 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -27,9 +27,9 @@ GUILE_LOAD_COMPILED_PATH="@abs_top_builddir@${GUILE_LOAD_COMPILED_PATH:+:}$GUILE GUILE_LOAD_PATH="@abs_top_builddir@:@abs_top_srcdir@${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH -# Define $PATH so that `guix-build' and friends are easily found. +# Define $PATH so that `guix' and friends are easily found. -PATH="@abs_top_builddir@:$PATH" +PATH="@abs_top_builddir@/scripts:@abs_top_builddir@:$PATH" export PATH # Daemon helpers. @@ -43,7 +43,12 @@ export NIX_ROOT_FINDER NIX_SETUID_HELPER # auto-compilation. NIX_HASH="@NIX_HASH@" - export NIX_HASH +# Define $GUIX_UNINSTALLED to prevent `guix' from +# prepending @guilemoduledir@ to the Guile load paths. + +GUIX_UNINSTALLED=1 +export GUIX_UNINSTALLED + exec "$@" diff --git a/scripts/guix.in b/scripts/guix.in new file mode 100644 index 0000000000..2fdde7d13a --- /dev/null +++ b/scripts/guix.in @@ -0,0 +1,56 @@ +#!@GUILE@ -s +-*- scheme -*- +!# +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Mark H Weaver +;;; +;;; 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 . + +;; IMPORTANT: We must avoid loading any modules from Guix here, +;; because we need to adjust the guile load paths first. +;; It's okay to import modules from core Guile though. +(use-modules (ice-9 regex)) + +(let () + (define-syntax-rule (push! elt v) (set! v (cons elt v))) + + (define config-lookup + (let ((config '(("prefix" . "@prefix@") + ("datarootdir" . "@datarootdir@") + ("guilemoduledir" . "@guilemoduledir@"))) + (var-ref-regexp (make-regexp "\\$\\{([a-z]+)\\}"))) + (define (expand-var-ref match) + (lookup (match:substring match 1))) + (define (expand str) + (regexp-substitute/global #f var-ref-regexp str + 'pre expand-var-ref 'post)) + (define (lookup name) + (expand (assoc-ref config name))) + lookup)) + + (define (maybe-augment-load-paths!) + (unless (getenv "GUIX_UNINSTALLED") + (let ((module-dir (config-lookup "guilemoduledir"))) + (push! module-dir %load-path) + (push! module-dir %load-compiled-path)))) + + (define (run-guix-main) + (let ((guix-main (module-ref (resolve-interface '(guix ui)) + 'guix-main))) + (apply guix-main (command-line)))) + + (maybe-augment-load-paths!) + (run-guix-main)) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 5718b07d0c..721a7c6769 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -17,44 +17,44 @@ # along with GNU Guix. If not, see . # -# Test the `guix-build' command-line utility. +# Test the `guix build' command-line utility. # -guix-build --version +guix build --version # Should fail. -if guix-build -e +; +if guix build -e +; then false; else true; fi # Should fail because this is a source-less package. -if guix-build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S +if guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S then false; else true; fi # Should pass. -guix-build -e '(@@ (gnu packages base) %bootstrap-guile)' | \ +guix build -e '(@@ (gnu packages base) %bootstrap-guile)' | \ grep -e '-guile-' -guix-build hello -d | \ +guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' # Should fail because the name/version combination could not be found. -if guix-build hello-0.0.1 -n; then false; else true; fi +if guix build hello-0.0.1 -n; then false; else true; fi # Keep a symlink to the result, registered as a root. result="t-result-$$" -guix-build -r "$result" \ +guix build -r "$result" \ -e '(@@ (gnu packages base) %bootstrap-guile)' test -x "$result/bin/guile" # Should fail, because $result already exists. -if guix-build -r "$result" -e '(@@ (gnu packages base) %bootstrap-guile)' +if guix build -r "$result" -e '(@@ (gnu packages base) %bootstrap-guile)' then false; else true; fi rm -f "$result" # Parsing package names and versions. -guix-build -n time # PASS -guix-build -n time-1.7 # PASS, version found -if guix-build -n time-3.2; # FAIL, version not found +guix build -n time # PASS +guix build -n time-1.7 # PASS, version found +if guix build -n time-3.2; # FAIL, version not found then false; else true; fi -if guix-build -n something-that-will-never-exist; # FAIL +if guix build -n something-that-will-never-exist; # FAIL then false; else true; fi diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 0d39ff4c24..698516490b 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -23,7 +23,7 @@ set -e guix-daemon --version -guix-build --version +guix build --version -guix-build -e '(@ (gnu packages bootstrap) %bootstrap-guile)' -guix-build coreutils -n +guix build -e '(@ (gnu packages bootstrap) %bootstrap-guile)' +guix build coreutils -n diff --git a/tests/guix-download.sh b/tests/guix-download.sh index f0ea731430..7af6f181f6 100644 --- a/tests/guix-download.sh +++ b/tests/guix-download.sh @@ -17,20 +17,20 @@ # along with GNU Guix. If not, see . # -# Test the `guix-download' command-line utility. +# Test the `guix download' command-line utility. # -guix-download --version +guix download --version # Make sure it fails here. -if guix-download http://does.not/exist +if guix download http://does.not/exist then false; else true; fi -if guix-download unknown://some/where; +if guix download unknown://some/where; then false; else true; fi -if guix-download not/a/uri; +if guix download not/a/uri; then false; else true; fi # This one should succeed. -guix-download "file://$abs_top_srcdir/README" +guix download "file://$abs_top_srcdir/README" diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index 805300eeec..a90d085ab2 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -17,38 +17,38 @@ # along with GNU Guix. If not, see . # -# Test the `guix-gc' command-line utility. +# Test the `guix gc' command-line utility. # -guix-gc --version +guix gc --version trap "rm -f guix-gc-root" EXIT rm -f guix-gc-root # Add then reclaim a .drv file. -drv="`guix-build idutils -d`" +drv="`guix build idutils -d`" test -f "$drv" -guix-gc --list-dead | grep "$drv" -guix-gc --delete "$drv" +guix gc --list-dead | grep "$drv" +guix gc --delete "$drv" ! test -f "$drv" # Add a .drv, register it as a root. -drv="`guix-build --root=guix-gc-root lsh -d`" +drv="`guix build --root=guix-gc-root lsh -d`" test -f "$drv" && test -L guix-gc-root -guix-gc --list-live | grep "$drv" -if guix-gc --delete "$drv"; +guix gc --list-live | grep "$drv" +if guix gc --delete "$drv"; then false; else true; fi rm guix-gc-root -guix-gc --list-dead | grep "$drv" -guix-gc --delete "$drv" +guix gc --list-dead | grep "$drv" +guix gc --delete "$drv" ! test -f "$drv" # Try a random collection. -guix-gc -C 1KiB +guix gc -C 1KiB # Check trivial error cases. -if guix-gc --delete /dev/null; +if guix gc --delete /dev/null; then false; else true; fi diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 617318b796..cf8bc5c7e8 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -18,10 +18,10 @@ # along with GNU Guix. If not, see . # -# Test the `guix-package' command-line utility. +# Test the `guix package' command-line utility. # -guix-package --version +guix package --version readlink_base () { @@ -33,12 +33,12 @@ rm -f "$profile" trap 'rm "$profile" "$profile-"[0-9]* ; rm -rf t-home-'"$$" EXIT -guix-package --bootstrap -p "$profile" -i guile-bootstrap +guix package --bootstrap -p "$profile" -i guile-bootstrap test -L "$profile" && test -L "$profile-1-link" test -f "$profile/bin/guile" # Installing the same package a second time does nothing. -guix-package --bootstrap -p "$profile" -i guile-bootstrap +guix package --bootstrap -p "$profile" -i guile-bootstrap test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" @@ -46,8 +46,8 @@ test -f "$profile/bin/guile" # Check whether we have network access. if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then - boot_make="`guix-build -e '(@@ (gnu packages base) gnu-make-boot0)'`" - guix-package --bootstrap -p "$profile" -i "$boot_make" + boot_make="`guix build -e '(@@ (gnu packages base) gnu-make-boot0)'`" + guix package --bootstrap -p "$profile" -i "$boot_make" test -L "$profile-2-link" test -f "$profile/bin/make" && test -f "$profile/bin/guile" @@ -55,7 +55,7 @@ then # Check whether `--list-installed' works. # XXX: Change the tests when `--install' properly extracts the package # name and version string. - installed="`guix-package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`" + installed="`guix package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`" case "x$installed" in "guile-bootstrap make-boot0") true;; @@ -65,68 +65,68 @@ then false;; esac - test "`guix-package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap" + test "`guix package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap" # Search. - test "`guix-package -s "GNU Hello" | grep ^name:`" = "name: hello" - test "`guix-package -s "n0t4r341p4ck4g3"`" = "" + test "`guix package -s "GNU Hello" | grep ^name:`" = "name: hello" + test "`guix package -s "n0t4r341p4ck4g3"`" = "" # Remove a package. - guix-package --bootstrap -p "$profile" -r "guile-bootstrap" + guix package --bootstrap -p "$profile" -r "guile-bootstrap" test -L "$profile-3-link" test -f "$profile/bin/make" && ! test -f "$profile/bin/guile" # Roll back. - guix-package --roll-back -p "$profile" + guix package --roll-back -p "$profile" test "`readlink_base "$profile"`" = "$profile-2-link" test -x "$profile/bin/guile" && test -x "$profile/bin/make" - guix-package --roll-back -p "$profile" + guix package --roll-back -p "$profile" test "`readlink_base "$profile"`" = "$profile-1-link" test -x "$profile/bin/guile" && ! test -x "$profile/bin/make" # Move to the empty profile. for i in `seq 1 3` do - guix-package --bootstrap --roll-back -p "$profile" + guix package --bootstrap --roll-back -p "$profile" ! test -f "$profile/bin" ! test -f "$profile/lib" test "`readlink_base "$profile"`" = "$profile-0-link" done # Reinstall after roll-back to the empty profile. - guix-package --bootstrap -p "$profile" -i "$boot_make" + guix package --bootstrap -p "$profile" -i "$boot_make" test "`readlink_base "$profile"`" = "$profile-1-link" test -x "$profile/bin/guile" && ! test -x "$profile/bin/make" # Roll-back to generation 0, and install---all at once. - guix-package --bootstrap -p "$profile" --roll-back -i guile-bootstrap + guix package --bootstrap -p "$profile" --roll-back -i guile-bootstrap test "`readlink_base "$profile"`" = "$profile-1-link" test -x "$profile/bin/guile" && ! test -x "$profile/bin/make" # Install Make. - guix-package --bootstrap -p "$profile" -i "$boot_make" + guix package --bootstrap -p "$profile" -i "$boot_make" test "`readlink_base "$profile"`" = "$profile-2-link" test -x "$profile/bin/guile" && test -x "$profile/bin/make" # Make a "hole" in the list of generations, and make sure we can # roll back "over" it. rm "$profile-1-link" - guix-package --bootstrap -p "$profile" --roll-back + guix package --bootstrap -p "$profile" --roll-back test "`readlink_base "$profile"`" = "$profile-0-link" fi # Make sure the `:' syntax works. -guix-package --bootstrap -i "binutils:lib" -p "$profile" -n +guix package --bootstrap -i "binutils:lib" -p "$profile" -n # Make sure nonexistent outputs are reported. -guix-package --bootstrap -i "guile-bootstrap:out" -p "$profile" -n -if guix-package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n; +guix package --bootstrap -i "guile-bootstrap:out" -p "$profile" -n +if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n; then false; else true; fi -if guix-package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; +if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; then false; else true; fi # Check whether `--list-available' returns something sensible. -guix-package -A 'gui.*e' | grep guile +guix package -A 'gui.*e' | grep guile # # Try with the default profile. @@ -139,17 +139,17 @@ export HOME mkdir -p "$HOME" -guix-package --bootstrap -i guile-bootstrap +guix package --bootstrap -i guile-bootstrap test -L "$HOME/.guix-profile" test -f "$HOME/.guix-profile/bin/guile" if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then - guix-package --bootstrap -i "$boot_make" + guix package --bootstrap -i "$boot_make" test -f "$HOME/.guix-profile/bin/make" first_environment="`cd $HOME/.guix-profile ; pwd`" - guix-package --bootstrap --roll-back + guix package --bootstrap --roll-back test -f "$HOME/.guix-profile/bin/guile" ! test -f "$HOME/.guix-profile/bin/make" test "`cd $HOME/.guix-profile ; pwd`" = "$first_environment" @@ -159,12 +159,12 @@ fi default_profile="`readlink "$HOME/.guix-profile"`" for i in `seq 1 3` do - guix-package --bootstrap --roll-back + guix package --bootstrap --roll-back ! test -f "$HOME/.guix-profile/bin" ! test -f "$HOME/.guix-profile/lib" test "`readlink "$default_profile"`" = "$default_profile-0-link" done # Extraneous argument. -if guix-package install foo-bar; +if guix package install foo-bar; then false; else true; fi -- cgit v1.2.3