[jackhill/guix/guix.git] / guix / profiles.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; 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 ui)
  #:use-module (guix utils)
  #:use-module (guix records)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #: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)
  #: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-item
            manifest-entry-dependencies

            manifest-pattern
            manifest-pattern?

            manifest-remove
            manifest-add
            manifest-installed?
            manifest-matching-entries

            manifest-transaction
            manifest-transaction?
            manifest-transaction-install
            manifest-transaction-remove
            manifest-perform-transaction
            manifest-transaction-effects
            manifest-show-transaction

            profile-manifest
            package->manifest-entry
            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:

\f
;;;
;;; 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"))
  (item         manifest-entry-item)              ; package | store path
  (dependencies manifest-entry-dependencies       ; (store path | package)*
                (default '())))

(define-record-type* <manifest-pattern> manifest-pattern
  make-manifest-pattern
  manifest-pattern?
  (name         manifest-pattern-name)            ; string
  (version      manifest-pattern-version          ; string | #f
                (default #f))
  (output       manifest-pattern-output           ; string | #f
                (default "out")))

(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* (package->manifest-entry package #:optional output)
  "Return a manifest entry for the OUTPUT of package PACKAGE.  When OUTPUT is
omitted or #f, use the first output of PACKAGE."
  (let ((deps (map (match-lambda
                    ((label package)
                     `(,package "out"))
                    ((label package output)
                     `(,package ,output)))
                   (package-transitive-propagated-inputs package))))
    (manifest-entry
     (name (package-name package))
     (version (package-version package))
     (output (or output (car (package-outputs package))))
     (item package)
     (dependencies (delete-duplicates deps)))))

(define (manifest->gexp manifest)
  "Return a representation of MANIFEST as a gexp."
  (define (entry->gexp entry)
    (match entry
      (($ <manifest-entry> name version output (? string? path) (deps ...))
       #~(#$name #$version #$output #$path #$deps))
      (($ <manifest-entry> name version output (? package? package) (deps ...))
       #~(#$name #$version #$output
                 (ungexp package (or output "out")) #$deps))))

  (match manifest
    (($ <manifest> (entries ...))
     #~(manifest (version 1)
                 (packages #$(map entry->gexp 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)
              (item 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)
             ;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
             ;; "/gnu/store/...-gmp") for instance.  Discard the 'label' in
             ;; such lists.
             (let ((deps (match deps
                           (((labels directories) ...)
                            directories)
                           ((directories ...)
                            directories))))
               (manifest-entry
                 (name name)
                 (version version)
                 (output output)
                 (item 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 (entry-predicate pattern)
  "Return a procedure that returns #t when passed a manifest entry that
matches NAME/OUTPUT/VERSION.  OUTPUT and VERSION may be #f, in which case they
are ignored."
  (match pattern
    (($ <manifest-pattern> name version output)
     (match-lambda
      (($ <manifest-entry> entry-name entry-version entry-output)
       (and (string=? entry-name name)
            (or (not entry-output) (not output)
                (string=? entry-output output))
            (or (not version)
                (string=? entry-version version))))))))

(define (manifest-remove manifest patterns)
  "Remove entries for each of PATTERNS from MANIFEST.  Each item in PATTERNS
must be a manifest-pattern."
  (define (remove-entry pattern lst)
    (remove (entry-predicate pattern) lst))

  (make-manifest (fold remove-entry
                       (manifest-entries manifest)
                       patterns)))

(define (manifest-add manifest entries)
  "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
Remove MANIFEST entries that have the same name and output as ENTRIES."
  (define (same-entry? entry name output)
    (match entry
      (($ <manifest-entry> entry-name _ entry-output _ ...)
       (and (equal? name entry-name)
            (equal? output entry-output)))))

  (make-manifest
   (append entries
           (fold (lambda (entry result)
                   (match entry
                     (($ <manifest-entry> name _ out _ ...)
                      (filter (negate (cut same-entry? <> name out))
                              result))))
                 (manifest-entries manifest)
                 entries))))

(define (manifest-installed? manifest pattern)
  "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
#f otherwise."
  (->bool (find (entry-predicate pattern)
                (manifest-entries manifest))))

(define (manifest-matching-entries manifest patterns)
  "Return all the entries of MANIFEST that match one of the PATTERNS."
  (define predicates
    (map entry-predicate patterns))

  (define (matches? entry)
    (any (lambda (pred)
           (pred entry))
         predicates))

  (filter matches? (manifest-entries manifest)))

\f
;;;
;;; Manifest transactions.
;;;

(define-record-type* <manifest-transaction> manifest-transaction
  make-manifest-transaction
  manifest-transaction?
  (install manifest-transaction-install ; list of <manifest-entry>
           (default '()))
  (remove  manifest-transaction-remove  ; list of <manifest-pattern>
           (default '())))

(define (manifest-transaction-effects manifest transaction)
  "Compute the effect of applying TRANSACTION to MANIFEST.  Return 3 values:
the list of packages that would be removed, installed, or upgraded when
applying TRANSACTION to MANIFEST."
  (define (manifest-entry->pattern entry)
    (manifest-pattern
      (name   (manifest-entry-name entry))
      (output (manifest-entry-output entry))))

  (let loop ((input    (manifest-transaction-install transaction))
             (install '())
             (upgrade '()))
    (match input
      (()
       (let ((remove (manifest-transaction-remove transaction)))
         (values (manifest-matching-entries manifest remove)
                 (reverse install) (reverse upgrade))))
      ((entry rest ...)
       ;; Check whether installing ENTRY corresponds to the installation of a
       ;; new package or to an upgrade.

       ;; XXX: When the exact same output directory is installed, we're not
       ;; really upgrading anything.  Add a check for that case.
       (let* ((pattern  (manifest-entry->pattern entry))
              (upgrade? (manifest-installed? manifest pattern)))
         (loop rest
               (if upgrade? install (cons entry install))
               (if upgrade? (cons entry upgrade) upgrade)))))))

(define (manifest-perform-transaction manifest transaction)
  "Perform TRANSACTION on MANIFEST and return new manifest."
  (let ((install (manifest-transaction-install transaction))
        (remove  (manifest-transaction-remove transaction)))
    (manifest-add (manifest-remove manifest remove)
                  install)))

(define* (manifest-show-transaction store manifest transaction
                                    #:key dry-run?)
  "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
  (define (package-strings name version output item)
    (map (lambda (name version output item)
           (format #f "   ~a-~a\t~a\t~a" name version output
                   (if (package? item)
                       (package-output store item output)
                       item)))
         name version output item))

  (let-values (((remove install upgrade)
                (manifest-transaction-effects manifest transaction)))
    (match remove
      ((($ <manifest-entry> name version output item _) ..1)
       (let ((len    (length name))
             (remove (package-strings name version output item)))
         (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 upgrade
      ((($ <manifest-entry> name version output item _) ..1)
       (let ((len     (length name))
             (upgrade (package-strings name version output item)))
         (if dry-run?
             (format (current-error-port)
                     (N_ "The following package would be upgraded:~%~{~a~%~}~%"
                         "The following packages would be upgraded:~%~{~a~%~}~%"
                         len)
                     upgrade)
             (format (current-error-port)
                     (N_ "The following package will be upgraded:~%~{~a~%~}~%"
                         "The following packages will be upgraded:~%~{~a~%~}~%"
                         len)
                     upgrade))))
      (_ #f))
    (match install
      ((($ <manifest-entry> name version output item _) ..1)
       (let ((len     (length name))
             (install (package-strings name version output item)))
         (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))))

\f
;;;
;;; Profiles.
;;;

(define (manifest-inputs manifest)
  "Return the list of inputs for MANIFEST.  Each input has one of the
following forms:

  (PACKAGE OUTPUT-NAME)

or

  STORE-PATH
"
  (append-map (match-lambda
               (($ <manifest-entry> name version
                                    output (? package? package) deps)
                `((,package ,output) ,@deps))
               (($ <manifest-entry> name version output path deps)
                ;; Assume PATH and DEPS are already valid.
                `(,path ,@deps)))
              (manifest-entries manifest)))

(define (info-dir-file manifest)
  "Return a derivation that builds the 'dir' file for all the entries of
MANIFEST."
  (define texinfo                                 ;lazy reference
    (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
  (define gzip                                    ;lazy reference
    (module-ref (resolve-interface '(gnu packages compression)) 'gzip))

  (define build
    #~(begin
        (use-modules (guix build utils)
                     (srfi srfi-1) (srfi srfi-26)
                     (ice-9 ftw))

        (define (info-file? file)
          (or (string-suffix? ".info" file)
              (string-suffix? ".info.gz" file)))

        (define (info-files top)
          (let ((infodir (string-append top "/share/info")))
            (map (cut string-append infodir "/" <>)
                 (or (scandir infodir info-file?) '()))))

        (define (install-info info)
          (setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
          (zero?
           (system* (string-append #+texinfo "/bin/install-info")
                    info (string-append #$output "/share/info/dir"))))

        (mkdir-p (string-append #$output "/share/info"))
        (every install-info
               (append-map info-files
                           '#$(manifest-inputs manifest)))))

  ;; Don't depend on Texinfo when there's nothing to do.
  (if (null? (manifest-entries manifest))
      (gexp->derivation "info-dir" #~(mkdir #$output))
      (gexp->derivation "info-dir" build
                        #:modules '((guix build utils)))))

(define* (profile-derivation manifest #:key (info-dir? #t))
  "Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST.  The profile includes a top-level Info 'dir' file, unless
INFO-DIR? is #f."
  (mlet %store-monad ((info-dir (if info-dir?
                                    (info-dir-file manifest)
                                    (return #f))))
    (define inputs
      (if info-dir
          (cons info-dir (manifest-inputs manifest))
          (manifest-inputs manifest)))

    (define builder
      #~(begin
          (use-modules (ice-9 pretty-print)
                       (guix build union))

          (setvbuf (current-output-port) _IOLBF)
          (setvbuf (current-error-port) _IOLBF)

          (union-build #$output '#$inputs
                       #:log-port (%make-void-port "w"))
          (call-with-output-file (string-append #$output "/manifest")
            (lambda (p)
              (pretty-print '#$(manifest->gexp manifest) p)))))

    (gexp->derivation "profile" builder
                      #:modules '((guix build union))
                      #:local-build? #t)))

(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
Commit	Line	Data
cc4ecc2d	1	;;; GNU Guix --- Functional package management for GNU
9e55f04a	2	;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
cc4ecc2d	3	;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
343745c8	4	;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
cc4ecc2d LC	5	;;;
	6	;;; This file is part of GNU Guix.
	7	;;;
	8	;;; GNU Guix is free software; you can redistribute it and/or modify it
	9	;;; under the terms of the GNU General Public License as published by
	10	;;; the Free Software Foundation; either version 3 of the License, or (at
	11	;;; your option) any later version.
	12	;;;
	13	;;; GNU Guix is distributed in the hope that it will be useful, but
	14	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	15	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	;;; GNU General Public License for more details.
	17	;;;
	18	;;; You should have received a copy of the GNU General Public License
	19	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	20
	21	(define-module (guix profiles)
343745c8	22	#:use-module (guix ui)
cc4ecc2d LC	23	#:use-module (guix utils)
	24	#:use-module (guix records)
	25	#:use-module (guix derivations)
	26	#:use-module (guix packages)
a54c94a4	27	#:use-module (guix gexp)
79ee406d	28	#:use-module (guix monads)
cc4ecc2d LC	29	#:use-module (ice-9 match)
	30	#:use-module (ice-9 regex)
	31	#:use-module (ice-9 ftw)
343745c8	32	#:use-module (ice-9 format)
cc4ecc2d LC	33	#:use-module (srfi srfi-1)
cc4ecc2d LC	34	#:use-module (srfi srfi-9)
79601521	35	#:use-module (srfi srfi-11)
cc4ecc2d LC	36	#:use-module (srfi srfi-19)
	37	#:use-module (srfi srfi-26)
	38	#:export (manifest make-manifest
	39	manifest?
	40	manifest-entries
	41
	42	<manifest-entry> ; FIXME: eventually make it internal
	43	manifest-entry
	44	manifest-entry?
	45	manifest-entry-name
	46	manifest-entry-version
	47	manifest-entry-output
a54c94a4	48	manifest-entry-item
cc4ecc2d LC	49	manifest-entry-dependencies
cc4ecc2d LC	50
a2078770 LC	51	manifest-pattern
	52	manifest-pattern?
	53
cc4ecc2d	54	manifest-remove
f7554030	55	manifest-add
cc4ecc2d	56	manifest-installed?
a2078770	57	manifest-matching-entries
cc4ecc2d	58
343745c8 AK	59	manifest-transaction
	60	manifest-transaction?
	61	manifest-transaction-install
	62	manifest-transaction-remove
	63	manifest-perform-transaction
79601521	64	manifest-transaction-effects
343745c8 AK	65	manifest-show-transaction
343745c8 AK	66
cc4ecc2d	67	profile-manifest
462f5cca	68	package->manifest-entry
cc4ecc2d LC	69	profile-derivation
	70	generation-number
	71	generation-numbers
	72	previous-generation-number
	73	generation-time
	74	generation-file-name))
	75
	76	;;; Commentary:
	77	;;;
	78	;;; Tools to create and manipulate profiles---i.e., the representation of a
	79	;;; set of installed packages.
	80	;;;
	81	;;; Code:
	82
	83	\f
	84	;;;
	85	;;; Manifests.
	86	;;;
	87
	88	(define-record-type <manifest>
	89	(manifest entries)
	90	manifest?
	91	(entries manifest-entries)) ; list of <manifest-entry>
	92
	93	;; Convenient alias, to avoid name clashes.
	94	(define make-manifest manifest)
	95
	96	(define-record-type* <manifest-entry> manifest-entry
	97	make-manifest-entry
	98	manifest-entry?
	99	(name manifest-entry-name) ; string
	100	(version manifest-entry-version) ; string
	101	(output manifest-entry-output ; string
	102	(default "out"))
a54c94a4	103	(item manifest-entry-item) ; package \| store path
4ca0b410 LC	104	(dependencies manifest-entry-dependencies ; (store path \| package)*
4ca0b410 LC	105	(default '())))
cc4ecc2d	106
a2078770 LC	107	(define-record-type* <manifest-pattern> manifest-pattern
	108	make-manifest-pattern
	109	manifest-pattern?
	110	(name manifest-pattern-name) ; string
	111	(version manifest-pattern-version ; string \| #f
	112	(default #f))
	113	(output manifest-pattern-output ; string \| #f
	114	(default "out")))
	115
cc4ecc2d LC	116	(define (profile-manifest profile)
	117	"Return the PROFILE's manifest."
	118	(let ((file (string-append profile "/manifest")))
	119	(if (file-exists? file)
	120	(call-with-input-file file read-manifest)
	121	(manifest '()))))
	122
462f5cca LC	123	(define* (package->manifest-entry package #:optional output)
	124	"Return a manifest entry for the OUTPUT of package PACKAGE. When OUTPUT is
	125	omitted or #f, use the first output of PACKAGE."
	126	(let ((deps (map (match-lambda
	127	((label package)
	128	`(,package "out"))
	129	((label package output)
	130	`(,package ,output)))
	131	(package-transitive-propagated-inputs package))))
	132	(manifest-entry
	133	(name (package-name package))
	134	(version (package-version package))
	135	(output (or output (car (package-outputs package))))
	136	(item package)
	137	(dependencies (delete-duplicates deps)))))
	138
a54c94a4 LC	139	(define (manifest->gexp manifest)
	140	"Return a representation of MANIFEST as a gexp."
	141	(define (entry->gexp entry)
cc4ecc2d	142	(match entry
a54c94a4 LC	143	(($ <manifest-entry> name version output (? string? path) (deps ...))
	144	#~(#$name #$version #$output #$path #$deps))
	145	(($ <manifest-entry> name version output (? package? package) (deps ...))
	146	#~(#$name #$version #$output
	147	(ungexp package (or output "out")) #$deps))))
cc4ecc2d LC	148
	149	(match manifest
	150	(($ <manifest> (entries ...))
a54c94a4 LC	151	#~(manifest (version 1)
a54c94a4 LC	152	(packages #$(map entry->gexp entries))))))
cc4ecc2d LC	153
	154	(define (sexp->manifest sexp)
	155	"Parse SEXP as a manifest."
	156	(match sexp
	157	(('manifest ('version 0)
	158	('packages ((name version output path) ...)))
	159	(manifest
	160	(map (lambda (name version output path)
	161	(manifest-entry
	162	(name name)
	163	(version version)
	164	(output output)
a54c94a4	165	(item path)))
cc4ecc2d LC	166	name version output path)))
	167
	168	;; Version 1 adds a list of propagated inputs to the
	169	;; name/version/output/path tuples.
	170	(('manifest ('version 1)
	171	('packages ((name version output path deps) ...)))
	172	(manifest
	173	(map (lambda (name version output path deps)
d34736c5 LC	174	;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
	175	;; "/gnu/store/...-gmp") for instance. Discard the 'label' in
	176	;; such lists.
	177	(let ((deps (match deps
	178	(((labels directories) ...)
	179	directories)
	180	((directories ...)
	181	directories))))
	182	(manifest-entry
	183	(name name)
	184	(version version)
	185	(output output)
	186	(item path)
	187	(dependencies deps))))
cc4ecc2d LC	188	name version output path deps)))
	189
	190	(_
	191	(error "unsupported manifest format" manifest))))
	192
	193	(define (read-manifest port)
	194	"Return the packages listed in MANIFEST."
	195	(sexp->manifest (read port)))
	196
a2078770 LC	197	(define (entry-predicate pattern)
	198	"Return a procedure that returns #t when passed a manifest entry that
	199	matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
	200	are ignored."
	201	(match pattern
	202	(($ <manifest-pattern> name version output)
	203	(match-lambda
	204	(($ <manifest-entry> entry-name entry-version entry-output)
	205	(and (string=? entry-name name)
	206	(or (not entry-output) (not output)
	207	(string=? entry-output output))
	208	(or (not version)
	209	(string=? entry-version version))))))))
	210
	211	(define (manifest-remove manifest patterns)
	212	"Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
	213	must be a manifest-pattern."
	214	(define (remove-entry pattern lst)
	215	(remove (entry-predicate pattern) lst))
	216
	217	(make-manifest (fold remove-entry
cc4ecc2d	218	(manifest-entries manifest)
a2078770	219	patterns)))
cc4ecc2d	220
f7554030 AK	221	(define (manifest-add manifest entries)
	222	"Add a list of manifest ENTRIES to MANIFEST and return new manifest.
	223	Remove MANIFEST entries that have the same name and output as ENTRIES."
	224	(define (same-entry? entry name output)
	225	(match entry
	226	(($ <manifest-entry> entry-name _ entry-output _ ...)
	227	(and (equal? name entry-name)
	228	(equal? output entry-output)))))
	229
	230	(make-manifest
	231	(append entries
	232	(fold (lambda (entry result)
	233	(match entry
	234	(($ <manifest-entry> name _ out _ ...)
	235	(filter (negate (cut same-entry? <> name out))
	236	result))))
	237	(manifest-entries manifest)
	238	entries))))
	239
a2078770 LC	240	(define (manifest-installed? manifest pattern)
	241	"Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
	242	#f otherwise."
	243	(->bool (find (entry-predicate pattern)
cc4ecc2d LC	244	(manifest-entries manifest))))
cc4ecc2d LC	245
a2078770 LC	246	(define (manifest-matching-entries manifest patterns)
	247	"Return all the entries of MANIFEST that match one of the PATTERNS."
	248	(define predicates
	249	(map entry-predicate patterns))
	250
	251	(define (matches? entry)
	252	(any (lambda (pred)
	253	(pred entry))
	254	predicates))
	255
	256	(filter matches? (manifest-entries manifest)))
	257
cc4ecc2d	258	\f
343745c8 AK	259	;;;
	260	;;; Manifest transactions.
	261	;;;
	262
	263	(define-record-type* <manifest-transaction> manifest-transaction
	264	make-manifest-transaction
	265	manifest-transaction?
	266	(install manifest-transaction-install ; list of <manifest-entry>
	267	(default '()))
	268	(remove manifest-transaction-remove ; list of <manifest-pattern>
	269	(default '())))
	270
79601521 LC	271	(define (manifest-transaction-effects manifest transaction)
	272	"Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values:
	273	the list of packages that would be removed, installed, or upgraded when
	274	applying TRANSACTION to MANIFEST."
	275	(define (manifest-entry->pattern entry)
	276	(manifest-pattern
	277	(name (manifest-entry-name entry))
	278	(output (manifest-entry-output entry))))
	279
	280	(let loop ((input (manifest-transaction-install transaction))
	281	(install '())
	282	(upgrade '()))
	283	(match input
	284	(()
	285	(let ((remove (manifest-transaction-remove transaction)))
	286	(values (manifest-matching-entries manifest remove)
	287	(reverse install) (reverse upgrade))))
	288	((entry rest ...)
	289	;; Check whether installing ENTRY corresponds to the installation of a
	290	;; new package or to an upgrade.
	291
	292	;; XXX: When the exact same output directory is installed, we're not
	293	;; really upgrading anything. Add a check for that case.
	294	(let* ((pattern (manifest-entry->pattern entry))
	295	(upgrade? (manifest-installed? manifest pattern)))
	296	(loop rest
	297	(if upgrade? install (cons entry install))
	298	(if upgrade? (cons entry upgrade) upgrade)))))))
	299
343745c8 AK	300	(define (manifest-perform-transaction manifest transaction)
	301	"Perform TRANSACTION on MANIFEST and return new manifest."
	302	(let ((install (manifest-transaction-install transaction))
	303	(remove (manifest-transaction-remove transaction)))
	304	(manifest-add (manifest-remove manifest remove)
	305	install)))
	306
	307	(define* (manifest-show-transaction store manifest transaction
	308	#:key dry-run?)
	309	"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
6b74bb0a AK	310	(define (package-strings name version output item)
	311	(map (lambda (name version output item)
	312	(format #f " ~a-~a\t~a\t~a" name version output
	313	(if (package? item)
	314	(package-output store item output)
	315	item)))
	316	name version output item))
	317
79601521 LC	318	(let-values (((remove install upgrade)
79601521 LC	319	(manifest-transaction-effects manifest transaction)))
343745c8	320	(match remove
6b74bb0a	321	((($ <manifest-entry> name version output item _) ..1)
343745c8	322	(let ((len (length name))
6b74bb0a	323	(remove (package-strings name version output item)))
343745c8 AK	324	(if dry-run?
	325	(format (current-error-port)
	326	(N_ "The following package would be removed:~%~{~a~%~}~%"
	327	"The following packages would be removed:~%~{~a~%~}~%"
	328	len)
	329	remove)
	330	(format (current-error-port)
	331	(N_ "The following package will be removed:~%~{~a~%~}~%"
	332	"The following packages will be removed:~%~{~a~%~}~%"
	333	len)
	334	remove))))
	335	(_ #f))
6b74bb0a AK	336	(match upgrade
	337	((($ <manifest-entry> name version output item _) ..1)
	338	(let ((len (length name))
	339	(upgrade (package-strings name version output item)))
	340	(if dry-run?
	341	(format (current-error-port)
	342	(N_ "The following package would be upgraded:~%~{~a~%~}~%"
	343	"The following packages would be upgraded:~%~{~a~%~}~%"
	344	len)
	345	upgrade)
	346	(format (current-error-port)
	347	(N_ "The following package will be upgraded:~%~{~a~%~}~%"
	348	"The following packages will be upgraded:~%~{~a~%~}~%"
	349	len)
	350	upgrade))))
	351	(_ #f))
343745c8 AK	352	(match install
	353	((($ <manifest-entry> name version output item _) ..1)
	354	(let ((len (length name))
6b74bb0a	355	(install (package-strings name version output item)))
343745c8 AK	356	(if dry-run?
	357	(format (current-error-port)
	358	(N_ "The following package would be installed:~%~{~a~%~}~%"
	359	"The following packages would be installed:~%~{~a~%~}~%"
	360	len)
	361	install)
	362	(format (current-error-port)
	363	(N_ "The following package will be installed:~%~{~a~%~}~%"
	364	"The following packages will be installed:~%~{~a~%~}~%"
	365	len)
	366	install))))
	367	(_ #f))))
	368
	369	\f
cc4ecc2d LC	370	;;;
	371	;;; Profiles.
	372	;;;
	373
79ee406d LC	374	(define (manifest-inputs manifest)
	375	"Return the list of inputs for MANIFEST. Each input has one of the
	376	following forms:
	377
	378	(PACKAGE OUTPUT-NAME)
	379
	380	or
	381
	382	STORE-PATH
	383	"
	384	(append-map (match-lambda
	385	(($ <manifest-entry> name version
	386	output (? package? package) deps)
	387	`((,package ,output) ,@deps))
	388	(($ <manifest-entry> name version output path deps)
	389	;; Assume PATH and DEPS are already valid.
	390	`(,path ,@deps)))
	391	(manifest-entries manifest)))
	392
	393	(define (info-dir-file manifest)
	394	"Return a derivation that builds the 'dir' file for all the entries of
	395	MANIFEST."
2f0556ae LC	396	(define texinfo ;lazy reference
	397	(module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
	398	(define gzip ;lazy reference
	399	(module-ref (resolve-interface '(gnu packages compression)) 'gzip))
	400
79ee406d	401	(define build
a54c94a4	402	#~(begin
79ee406d LC	403	(use-modules (guix build utils)
	404	(srfi srfi-1) (srfi srfi-26)
	405	(ice-9 ftw))
	406
	407	(define (info-file? file)
	408	(or (string-suffix? ".info" file)
	409	(string-suffix? ".info.gz" file)))
	410
	411	(define (info-files top)
	412	(let ((infodir (string-append top "/share/info")))
	413	(map (cut string-append infodir "/" <>)
c2815c0f	414	(or (scandir infodir info-file?) '()))))
79ee406d LC	415
79ee406d LC	416	(define (install-info info)
2f0556ae	417	(setenv "PATH" (string-append #+gzip "/bin")) ;for info.gz files
79ee406d LC	418	(zero?
	419	(system* (string-append #+texinfo "/bin/install-info")
	420	info (string-append #$output "/share/info/dir"))))
	421
	422	(mkdir-p (string-append #$output "/share/info"))
	423	(every install-info
	424	(append-map info-files
	425	'#$(manifest-inputs manifest)))))
	426
	427	;; Don't depend on Texinfo when there's nothing to do.
	428	(if (null? (manifest-entries manifest))
	429	(gexp->derivation "info-dir" #~(mkdir #$output))
	430	(gexp->derivation "info-dir" build
	431	#:modules '((guix build utils)))))
	432
	433	(define* (profile-derivation manifest #:key (info-dir? #t))
	434	"Return a derivation that builds a profile (aka. 'user environment') with
	435	the given MANIFEST. The profile includes a top-level Info 'dir' file, unless
	436	INFO-DIR? is #f."
	437	(mlet %store-monad ((info-dir (if info-dir?
	438	(info-dir-file manifest)
	439	(return #f))))
	440	(define inputs
	441	(if info-dir
	442	(cons info-dir (manifest-inputs manifest))
	443	(manifest-inputs manifest)))
	444
	445	(define builder
	446	#~(begin
	447	(use-modules (ice-9 pretty-print)
	448	(guix build union))
	449
	450	(setvbuf (current-output-port) _IOLBF)
	451	(setvbuf (current-error-port) _IOLBF)
	452
	453	(union-build #$output '#$inputs
	454	#:log-port (%make-void-port "w"))
	455	(call-with-output-file (string-append #$output "/manifest")
	456	(lambda (p)
	457	(pretty-print '#$(manifest->gexp manifest) p)))))
	458
	459	(gexp->derivation "profile" builder
	460	#:modules '((guix build union))
	461	#:local-build? #t)))
cc4ecc2d LC	462
	463	(define (profile-regexp profile)
	464	"Return a regular expression that matches PROFILE's name and number."
	465	(make-regexp (string-append "^" (regexp-quote (basename profile))
	466	"-([0-9]+)")))
	467
	468	(define (generation-number profile)
	469	"Return PROFILE's number or 0. An absolute file name must be used."
	470	(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
	471	(basename (readlink profile))))
	472	(compose string->number (cut match:substring <> 1)))
	473	0))
	474
	475	(define (generation-numbers profile)
	476	"Return the sorted list of generation numbers of PROFILE, or '(0) if no
	477	former profiles were found."
	478	(define* (scandir name #:optional (select? (const #t))
	479	(entry<? (@ (ice-9 i18n) string-locale<?)))
	480	;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
	481	(define (enter? dir stat result)
	482	(and stat (string=? dir name)))
	483
	484	(define (visit basename result)
	485	(if (select? basename)
	486	(cons basename result)
	487	result))
	488
	489	(define (leaf name stat result)
	490	(and result
	491	(visit (basename name) result)))
	492
	493	(define (down name stat result)
	494	(visit "." '()))
	495
	496	(define (up name stat result)
	497	(visit ".." result))
	498
	499	(define (skip name stat result)
	500	;; All the sub-directories are skipped.
	501	(visit (basename name) result))
	502
	503	(define (error name* stat errno result)
	504	(if (string=? name name*) ; top-level NAME is unreadable
	505	result
	506	(visit (basename name*) result)))
	507
	508	(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
	509	(lambda (files)
	510	(sort files entry<?))))
	511
	512	(match (scandir (dirname profile)
	513	(cute regexp-exec (profile-regexp profile) <>))
	514	(#f ; no profile directory
	515	'(0))
	516	(() ; no profiles
	517	'(0))
	518	((profiles ...) ; former profiles around
	519	(sort (map (compose string->number
	520	(cut match:substring <> 1)
	521	(cute regexp-exec (profile-regexp profile) <>))
	522	profiles)
	523	<))))
	524
	525	(define (previous-generation-number profile number)
526	"Return the number of the generation before generation NUMBER of
527	PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
528	case when generations have been deleted (there are \"holes\")."
529	(fold (lambda (candidate highest)
530	(if (and (< candidate number) (> candidate highest))
531	candidate
532	highest))
533	0
534	(generation-numbers profile)))
535
536	(define (generation-file-name profile generation)
537	"Return the file name for PROFILE's GENERATION."
538	(format #f "~a-~a-link" profile generation))
539
540	(define (generation-time profile number)
541	"Return the creation time of a generation in the UTC format."
542	(make-time time-utc 0
543	(stat:ctime (stat (generation-file-name profile number)))))
544
545	;;; profiles.scm ends here