diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/profiles.scm | 315 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 343 |
3 files changed, 362 insertions, 297 deletions
diff --git a/Makefile.am b/Makefile.am index 7a74bc8601..1960b1b76d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -41,6 +41,7 @@ MODULES = \ guix/hash.scm \ guix/utils.scm \ guix/monads.scm \ + guix/profiles.scm \ guix/serialization.scm \ guix/nar.scm \ guix/derivations.scm \ diff --git a/guix/profiles.scm b/guix/profiles.scm new file mode 100644 index 0000000000..528f3c574b --- /dev/null +++ b/guix/profiles.scm @@ -0,0 +1,315 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix profiles) + #:use-module (guix utils) + #:use-module (guix records) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:export (manifest make-manifest + manifest? + manifest-entries + + <manifest-entry> ; FIXME: eventually make it internal + manifest-entry + manifest-entry? + manifest-entry-name + manifest-entry-version + manifest-entry-output + manifest-entry-path + manifest-entry-dependencies + + read-manifest + write-manifest + + manifest-remove + manifest-installed? + manifest=? + + profile-manifest + profile-derivation + generation-number + generation-numbers + previous-generation-number + generation-time + generation-file-name)) + +;;; Commentary: +;;; +;;; Tools to create and manipulate profiles---i.e., the representation of a +;;; set of installed packages. +;;; +;;; Code: + + +;;; +;;; Manifests. +;;; + +(define-record-type <manifest> + (manifest entries) + manifest? + (entries manifest-entries)) ; list of <manifest-entry> + +;; Convenient alias, to avoid name clashes. +(define make-manifest manifest) + +(define-record-type* <manifest-entry> manifest-entry + make-manifest-entry + manifest-entry? + (name manifest-entry-name) ; string + (version manifest-entry-version) ; string + (output manifest-entry-output ; string + (default "out")) + (path manifest-entry-path) ; store path + (dependencies manifest-entry-dependencies ; list of store paths + (default '())) + (inputs manifest-entry-inputs ; list of inputs to build + (default '()))) ; this entry + +(define (profile-manifest profile) + "Return the PROFILE's manifest." + (let ((file (string-append profile "/manifest"))) + (if (file-exists? file) + (call-with-input-file file read-manifest) + (manifest '())))) + +(define (manifest->sexp manifest) + "Return a representation of MANIFEST as an sexp." + (define (entry->sexp entry) + (match entry + (($ <manifest-entry> name version path output (deps ...)) + (list name version path output deps)))) + + (match manifest + (($ <manifest> (entries ...)) + `(manifest (version 1) + (packages ,(map entry->sexp entries)))))) + +(define (sexp->manifest sexp) + "Parse SEXP as a manifest." + (match sexp + (('manifest ('version 0) + ('packages ((name version output path) ...))) + (manifest + (map (lambda (name version output path) + (manifest-entry + (name name) + (version version) + (output output) + (path path))) + name version output path))) + + ;; Version 1 adds a list of propagated inputs to the + ;; name/version/output/path tuples. + (('manifest ('version 1) + ('packages ((name version output path deps) ...))) + (manifest + (map (lambda (name version output path deps) + (manifest-entry + (name name) + (version version) + (output output) + (path path) + (dependencies deps))) + name version output path deps))) + + (_ + (error "unsupported manifest format" manifest)))) + +(define (read-manifest port) + "Return the packages listed in MANIFEST." + (sexp->manifest (read port))) + +(define (write-manifest manifest port) + "Write MANIFEST to PORT." + (write (manifest->sexp manifest) port)) + +(define (remove-manifest-entry name lst) + "Remove the manifest entry named NAME from LST." + (remove (match-lambda + (($ <manifest-entry> entry-name) + (string=? name entry-name))) + lst)) + +(define (manifest-remove manifest names) + "Remove entries for each of NAMES from MANIFEST." + (make-manifest (fold remove-manifest-entry + (manifest-entries manifest) + names))) + +(define (manifest-installed? manifest name) + "Return #t if MANIFEST has an entry for NAME, #f otherwise." + (define (->bool x) + (not (not x))) + + (->bool (find (match-lambda + (($ <manifest-entry> entry-name) + (string=? entry-name name))) + (manifest-entries manifest)))) + +(define (manifest=? m1 m2) + "Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in +that the 'inputs' field is ignored for the comparison, since it is know to +have no effect on the manifest contents." + (equal? (manifest->sexp m1) + (manifest->sexp m2))) + + +;;; +;;; Profiles. +;;; + +(define* (lower-input store input #:optional (system (%current-system))) + "Lower INPUT so that it contains derivations instead of packages." + (match input + ((name (? package? package)) + `(,name ,(package-derivation store package system))) + ((name (? package? package) output) + `(,name ,(package-derivation store package system) + ,output)) + (_ input))) + +(define (profile-derivation store manifest) + "Return a derivation that builds a profile (aka. 'user environment') with +the given MANIFEST." + (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 profile '~a' with ~a packages...~%" + output (length inputs)) + (union-build output inputs + #:log-port (%make-void-port "w")) + (call-with-output-file (string-append output "/manifest") + (lambda (p) + (pretty-print ',(manifest->sexp manifest) p)))))) + + (build-expression->derivation store "profile" + (%current-system) + builder + (append-map (match-lambda + (($ <manifest-entry> name version + output path deps (inputs ..1)) + (map (cute lower-input store <>) + inputs)) + (($ <manifest-entry> name version + output path deps) + ;; Assume PATH and DEPS are + ;; already valid. + `((,name ,path) ,@deps))) + (manifest-entries manifest)) + #:modules '((guix build union)))) + +(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 (generation-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 (generation-numbers profile) + "Return the sorted list of generation numbers of PROFILE, or '(0) if no +former profiles were found." + (define* (scandir name #:optional (select? (const #t)) + (entry<? (@ (ice-9 i18n) string-locale<?))) + ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. + (define (enter? dir stat result) + (and stat (string=? dir name))) + + (define (visit basename result) + (if (select? basename) + (cons basename result) + result)) + + (define (leaf name stat result) + (and result + (visit (basename name) result))) + + (define (down name stat result) + (visit "." '())) + + (define (up name stat result) + (visit ".." result)) + + (define (skip name stat result) + ;; All the sub-directories are skipped. + (visit (basename name) result)) + + (define (error name* stat errno result) + (if (string=? name name*) ; top-level NAME is unreadable + result + (visit (basename name*) result))) + + (and=> (file-system-fold enter? leaf down up skip error #f name lstat) + (lambda (files) + (sort files entry<?)))) + + (match (scandir (dirname profile) + (cute regexp-exec (profile-regexp profile) <>)) + (#f ; no profile directory + '(0)) + (() ; no profiles + '(0)) + ((profiles ...) ; former profiles around + (sort (map (compose string->number + (cut match:substring <> 1) + (cute regexp-exec (profile-regexp profile) <>)) + profiles) + <)))) + +(define (previous-generation-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 + (generation-numbers profile))) + +(define (generation-file-name profile generation) + "Return the file name for PROFILE's GENERATION." + (format #f "~a-~a-link" profile generation)) + +(define (generation-time profile number) + "Return the creation time of a generation in the UTC format." + (make-time time-utc 0 + (stat:ctime (stat (generation-file-name profile number))))) + +;;; profiles.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 008ae53b47..4dbe2b7b63 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -23,22 +23,19 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) + #:use-module (guix profiles) #:use-module (guix utils) #:use-module (guix config) - #:use-module (guix records) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module ((guix ftp-client) #:select (ftp-open)) - #: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-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #: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)) @@ -51,7 +48,7 @@ ;;; -;;; User profile. +;;; Profiles. ;;; (define %user-profile-directory @@ -69,240 +66,6 @@ ;; coexist with Nix profiles. (string-append %profile-directory "/guix-profile")) - -;;; -;;; Manifests. -;;; - -(define-record-type <manifest> - (manifest entries) - manifest? - (entries manifest-entries)) ; list of <manifest-entry> - -;; Convenient alias, to avoid name clashes. -(define make-manifest manifest) - -(define-record-type* <manifest-entry> manifest-entry - make-manifest-entry - manifest-entry? - (name manifest-entry-name) ; string - (version manifest-entry-version) ; string - (output manifest-entry-output ; string - (default "out")) - (path manifest-entry-path) ; store path - (dependencies manifest-entry-dependencies ; list of store paths - (default '())) - (inputs manifest-entry-inputs ; list of inputs to build - (default '()))) ; this entry - -(define (profile-manifest profile) - "Return the PROFILE's manifest." - (let ((file (string-append profile "/manifest"))) - (if (file-exists? file) - (call-with-input-file file read-manifest) - (manifest '())))) - -(define (manifest->sexp manifest) - "Return a representation of MANIFEST as an sexp." - (define (entry->sexp entry) - (match entry - (($ <manifest-entry> name version path output (deps ...)) - (list name version path output deps)))) - - (match manifest - (($ <manifest> (entries ...)) - `(manifest (version 1) - (packages ,(map entry->sexp entries)))))) - -(define (sexp->manifest sexp) - "Parse SEXP as a manifest." - (match sexp - (('manifest ('version 0) - ('packages ((name version output path) ...))) - (manifest - (map (lambda (name version output path) - (manifest-entry - (name name) - (version version) - (output output) - (path path))) - name version output path))) - - ;; Version 1 adds a list of propagated inputs to the - ;; name/version/output/path tuples. - (('manifest ('version 1) - ('packages ((name version output path deps) ...))) - (manifest - (map (lambda (name version output path deps) - (manifest-entry - (name name) - (version version) - (output output) - (path path) - (dependencies deps))) - name version output path deps))) - - (_ - (error "unsupported manifest format" manifest)))) - -(define (read-manifest port) - "Return the packages listed in MANIFEST." - (sexp->manifest (read port))) - -(define (write-manifest manifest port) - "Write MANIFEST to PORT." - (write (manifest->sexp manifest) port)) - -(define (remove-manifest-entry name lst) - "Remove the manifest entry named NAME from LST." - (remove (match-lambda - (($ <manifest-entry> entry-name) - (string=? name entry-name))) - lst)) - -(define (manifest-remove manifest names) - "Remove entries for each of NAMES from MANIFEST." - (make-manifest (fold remove-manifest-entry - (manifest-entries manifest) - names))) - -(define (manifest-installed? manifest name) - "Return #t if MANIFEST has an entry for NAME, #f otherwise." - (define (->bool x) - (not (not x))) - - (->bool (find (match-lambda - (($ <manifest-entry> entry-name) - (string=? entry-name name))) - (manifest-entries manifest)))) - -(define (manifest=? m1 m2) - "Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in -that the 'inputs' field is ignored for the comparison, since it is know to -have no effect on the manifest contents." - (equal? (manifest->sexp m1) - (manifest->sexp m2))) - - -;;; -;;; Profiles. -;;; - -(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 (generation-numbers profile) - "Return the sorted list of generation numbers of PROFILE, or '(0) if no -former profiles were found." - (define* (scandir name #:optional (select? (const #t)) - (entry<? (@ (ice-9 i18n) string-locale<?))) - ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. - (define (enter? dir stat result) - (and stat (string=? dir name))) - - (define (visit basename result) - (if (select? basename) - (cons basename result) - result)) - - (define (leaf name stat result) - (and result - (visit (basename name) result))) - - (define (down name stat result) - (visit "." '())) - - (define (up name stat result) - (visit ".." result)) - - (define (skip name stat result) - ;; All the sub-directories are skipped. - (visit (basename name) result)) - - (define (error name* stat errno result) - (if (string=? name name*) ; top-level NAME is unreadable - result - (visit (basename name*) result))) - - (and=> (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry<?)))) - - (match (scandir (dirname profile) - (cute regexp-exec (profile-regexp profile) <>)) - (#f ; no profile directory - '(0)) - (() ; no profiles - '(0)) - ((profiles ...) ; former profiles around - (sort (map (compose string->number - (cut match:substring <> 1) - (cute regexp-exec (profile-regexp profile) <>)) - profiles) - <)))) - -(define (previous-generation-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 - (generation-numbers profile))) - -(define (profile-derivation store manifest) - "Return a derivation that builds a profile (aka. 'user environment') with -the given MANIFEST." - (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 profile '~a' with ~a packages...~%" - output (length inputs)) - (union-build output inputs - #:log-port (%make-void-port "w")) - (call-with-output-file (string-append output "/manifest") - (lambda (p) - (pretty-print ',(manifest->sexp manifest) p)))))) - - (build-expression->derivation store "profile" - (%current-system) - builder - (append-map (match-lambda - (($ <manifest-entry> name version - output path deps (inputs ..1)) - (map (cute lower-input - (%store) <>) - inputs)) - (($ <manifest-entry> name version - output path deps) - ;; Assume PATH and DEPS are - ;; already valid. - `((,name ,path) ,@deps))) - (manifest-entries manifest)) - #:modules '((guix build union)))) - -(define (generation-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 (generation-file-name profile generation) - "Return the file name for PROFILE's GENERATION." - (format #f "~a-~a-link" profile generation)) - (define (link-to-empty-profile generation) "Link GENERATION, a string, to the empty profile." (let* ((drv (profile-derivation (%store) (manifest '()))) @@ -340,11 +103,6 @@ the given MANIFEST." (else (switch-to-previous-generation profile))))) ; anything else -(define (generation-time profile number) - "Return the creation time of a generation in the UTC format." - (make-time time-utc 0 - (stat:ctime (stat (generation-file-name profile number))))) - (define* (matching-generations str #:optional (profile %current-profile) #:key (duration-relation <=)) "Return the list of available generations matching a pattern in STR. See @@ -411,6 +169,50 @@ DURATION-RELATION with the current time." filter-by-duration) (else #f))) +(define (show-what-to-remove/install remove install dry-run?) + "Given the manifest entries listed in REMOVE and INSTALL, display the +packages that will/would be installed and removed." + ;; TODO: Report upgrades more clearly. + (match remove + ((($ <manifest-entry> name version _ path _) ..1) + (let ((len (length name)) + (remove (map (cut format #f " ~a-~a\t~a" <> <> <>) + name version path))) + (if dry-run? + (format (current-error-port) + (N_ "The following package would be removed:~% ~{~a~%~}~%" + "The following packages would be removed:~% ~{~a~%~}~%" + len) + remove) + (format (current-error-port) + (N_ "The following package will be removed:~% ~{~a~%~}~%" + "The following packages will be removed:~% ~{~a~%~}~%" + len) + remove)))) + (_ #f)) + (match install + ((($ <manifest-entry> name version output path _) ..1) + (let ((len (length name)) + (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>) + name version output path))) + (if dry-run? + (format (current-error-port) + (N_ "The following package would be installed:~%~{~a~%~}~%" + "The following packages would be installed:~%~{~a~%~}~%" + len) + install) + (format (current-error-port) + (N_ "The following package will be installed:~%~{~a~%~}~%" + "The following packages will be installed:~%~{~a~%~}~%" + len) + install)))) + (_ #f))) + + +;;; +;;; Package specifications. +;;; + (define (find-packages-by-description rx) "Return the list of packages whose name, synopsis, or description matches RX." @@ -437,16 +239,6 @@ RX." (package-name p2)))) same-location?)) -(define* (lower-input store input #:optional (system (%current-system))) - "Lower INPUT so that it contains derivations instead of packages." - (match input - ((name (? package? package)) - `(,name ,(package-derivation store package system))) - ((name (? package? package) output) - `(,name ,(package-derivation store package system) - ,output)) - (_ input))) - (define (input->name+path input) "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple." (let loop ((input input)) @@ -500,11 +292,6 @@ return its return value." (format (current-error-port) " interrupted by signal ~a~%" SIGINT) #f)))) - -;;; -;;; Package specifications. -;;; - (define newest-available-packages (memoize find-newest-available-packages)) @@ -989,44 +776,6 @@ more information.~%")) (and (equal? name entry-name) (equal? output entry-output))))) - (define (show-what-to-remove/install remove install dry-run?) - ;; Tell the user what's going to happen in high-level terms. - ;; TODO: Report upgrades more clearly. - (match remove - ((($ <manifest-entry> name version _ path _) ..1) - (let ((len (length name)) - (remove (map (cut format #f " ~a-~a\t~a" <> <> <>) - name version path))) - (if dry-run? - (format (current-error-port) - (N_ "The following package would be removed:~% ~{~a~%~}~%" - "The following packages would be removed:~% ~{~a~%~}~%" - len) - remove) - (format (current-error-port) - (N_ "The following package will be removed:~% ~{~a~%~}~%" - "The following packages will be removed:~% ~{~a~%~}~%" - len) - remove)))) - (_ #f)) - (match install - ((($ <manifest-entry> name version output path _) ..1) - (let ((len (length name)) - (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>) - name version output path))) - (if dry-run? - (format (current-error-port) - (N_ "The following package would be installed:~%~{~a~%~}~%" - "The following packages would be installed:~%~{~a~%~}~%" - len) - install) - (format (current-error-port) - (N_ "The following package will be installed:~%~{~a~%~}~%" - "The following packages will be installed:~%~{~a~%~}~%" - len) - install)))) - (_ #f))) - (define current-generation-number (generation-number profile)) |