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) |
cc4ecc2d LC |
28 | #:use-module (ice-9 match) |
29 | #:use-module (ice-9 regex) | |
30 | #:use-module (ice-9 ftw) | |
343745c8 | 31 | #:use-module (ice-9 format) |
cc4ecc2d LC |
32 | #:use-module (srfi srfi-1) |
33 | #:use-module (srfi srfi-9) | |
34 | #:use-module (srfi srfi-19) | |
35 | #:use-module (srfi srfi-26) | |
36 | #:export (manifest make-manifest | |
37 | manifest? | |
38 | manifest-entries | |
39 | ||
40 | <manifest-entry> ; FIXME: eventually make it internal | |
41 | manifest-entry | |
42 | manifest-entry? | |
43 | manifest-entry-name | |
44 | manifest-entry-version | |
45 | manifest-entry-output | |
a54c94a4 | 46 | manifest-entry-item |
cc4ecc2d LC |
47 | manifest-entry-dependencies |
48 | ||
a2078770 LC |
49 | manifest-pattern |
50 | manifest-pattern? | |
51 | ||
cc4ecc2d | 52 | manifest-remove |
f7554030 | 53 | manifest-add |
cc4ecc2d | 54 | manifest-installed? |
a2078770 | 55 | manifest-matching-entries |
cc4ecc2d | 56 | |
343745c8 AK |
57 | manifest-transaction |
58 | manifest-transaction? | |
59 | manifest-transaction-install | |
60 | manifest-transaction-remove | |
61 | manifest-perform-transaction | |
62 | manifest-show-transaction | |
63 | ||
cc4ecc2d | 64 | profile-manifest |
462f5cca | 65 | package->manifest-entry |
cc4ecc2d LC |
66 | profile-derivation |
67 | generation-number | |
68 | generation-numbers | |
69 | previous-generation-number | |
70 | generation-time | |
71 | generation-file-name)) | |
72 | ||
73 | ;;; Commentary: | |
74 | ;;; | |
75 | ;;; Tools to create and manipulate profiles---i.e., the representation of a | |
76 | ;;; set of installed packages. | |
77 | ;;; | |
78 | ;;; Code: | |
79 | ||
80 | \f | |
81 | ;;; | |
82 | ;;; Manifests. | |
83 | ;;; | |
84 | ||
85 | (define-record-type <manifest> | |
86 | (manifest entries) | |
87 | manifest? | |
88 | (entries manifest-entries)) ; list of <manifest-entry> | |
89 | ||
90 | ;; Convenient alias, to avoid name clashes. | |
91 | (define make-manifest manifest) | |
92 | ||
93 | (define-record-type* <manifest-entry> manifest-entry | |
94 | make-manifest-entry | |
95 | manifest-entry? | |
96 | (name manifest-entry-name) ; string | |
97 | (version manifest-entry-version) ; string | |
98 | (output manifest-entry-output ; string | |
99 | (default "out")) | |
a54c94a4 | 100 | (item manifest-entry-item) ; package | store path |
4ca0b410 LC |
101 | (dependencies manifest-entry-dependencies ; (store path | package)* |
102 | (default '()))) | |
cc4ecc2d | 103 | |
a2078770 LC |
104 | (define-record-type* <manifest-pattern> manifest-pattern |
105 | make-manifest-pattern | |
106 | manifest-pattern? | |
107 | (name manifest-pattern-name) ; string | |
108 | (version manifest-pattern-version ; string | #f | |
109 | (default #f)) | |
110 | (output manifest-pattern-output ; string | #f | |
111 | (default "out"))) | |
112 | ||
cc4ecc2d LC |
113 | (define (profile-manifest profile) |
114 | "Return the PROFILE's manifest." | |
115 | (let ((file (string-append profile "/manifest"))) | |
116 | (if (file-exists? file) | |
117 | (call-with-input-file file read-manifest) | |
118 | (manifest '())))) | |
119 | ||
462f5cca LC |
120 | (define* (package->manifest-entry package #:optional output) |
121 | "Return a manifest entry for the OUTPUT of package PACKAGE. When OUTPUT is | |
122 | omitted or #f, use the first output of PACKAGE." | |
123 | (let ((deps (map (match-lambda | |
124 | ((label package) | |
125 | `(,package "out")) | |
126 | ((label package output) | |
127 | `(,package ,output))) | |
128 | (package-transitive-propagated-inputs package)))) | |
129 | (manifest-entry | |
130 | (name (package-name package)) | |
131 | (version (package-version package)) | |
132 | (output (or output (car (package-outputs package)))) | |
133 | (item package) | |
134 | (dependencies (delete-duplicates deps))))) | |
135 | ||
a54c94a4 LC |
136 | (define (manifest->gexp manifest) |
137 | "Return a representation of MANIFEST as a gexp." | |
138 | (define (entry->gexp entry) | |
cc4ecc2d | 139 | (match entry |
a54c94a4 LC |
140 | (($ <manifest-entry> name version output (? string? path) (deps ...)) |
141 | #~(#$name #$version #$output #$path #$deps)) | |
142 | (($ <manifest-entry> name version output (? package? package) (deps ...)) | |
143 | #~(#$name #$version #$output | |
144 | (ungexp package (or output "out")) #$deps)))) | |
cc4ecc2d LC |
145 | |
146 | (match manifest | |
147 | (($ <manifest> (entries ...)) | |
a54c94a4 LC |
148 | #~(manifest (version 1) |
149 | (packages #$(map entry->gexp entries)))))) | |
cc4ecc2d LC |
150 | |
151 | (define (sexp->manifest sexp) | |
152 | "Parse SEXP as a manifest." | |
153 | (match sexp | |
154 | (('manifest ('version 0) | |
155 | ('packages ((name version output path) ...))) | |
156 | (manifest | |
157 | (map (lambda (name version output path) | |
158 | (manifest-entry | |
159 | (name name) | |
160 | (version version) | |
161 | (output output) | |
a54c94a4 | 162 | (item path))) |
cc4ecc2d LC |
163 | name version output path))) |
164 | ||
165 | ;; Version 1 adds a list of propagated inputs to the | |
166 | ;; name/version/output/path tuples. | |
167 | (('manifest ('version 1) | |
168 | ('packages ((name version output path deps) ...))) | |
169 | (manifest | |
170 | (map (lambda (name version output path deps) | |
d34736c5 LC |
171 | ;; Up to Guix 0.7 included, dependencies were listed as ("gmp" |
172 | ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in | |
173 | ;; such lists. | |
174 | (let ((deps (match deps | |
175 | (((labels directories) ...) | |
176 | directories) | |
177 | ((directories ...) | |
178 | directories)))) | |
179 | (manifest-entry | |
180 | (name name) | |
181 | (version version) | |
182 | (output output) | |
183 | (item path) | |
184 | (dependencies deps)))) | |
cc4ecc2d LC |
185 | name version output path deps))) |
186 | ||
187 | (_ | |
188 | (error "unsupported manifest format" manifest)))) | |
189 | ||
190 | (define (read-manifest port) | |
191 | "Return the packages listed in MANIFEST." | |
192 | (sexp->manifest (read port))) | |
193 | ||
a2078770 LC |
194 | (define (entry-predicate pattern) |
195 | "Return a procedure that returns #t when passed a manifest entry that | |
196 | matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they | |
197 | are ignored." | |
198 | (match pattern | |
199 | (($ <manifest-pattern> name version output) | |
200 | (match-lambda | |
201 | (($ <manifest-entry> entry-name entry-version entry-output) | |
202 | (and (string=? entry-name name) | |
203 | (or (not entry-output) (not output) | |
204 | (string=? entry-output output)) | |
205 | (or (not version) | |
206 | (string=? entry-version version)))))))) | |
207 | ||
208 | (define (manifest-remove manifest patterns) | |
209 | "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS | |
210 | must be a manifest-pattern." | |
211 | (define (remove-entry pattern lst) | |
212 | (remove (entry-predicate pattern) lst)) | |
213 | ||
214 | (make-manifest (fold remove-entry | |
cc4ecc2d | 215 | (manifest-entries manifest) |
a2078770 | 216 | patterns))) |
cc4ecc2d | 217 | |
f7554030 AK |
218 | (define (manifest-add manifest entries) |
219 | "Add a list of manifest ENTRIES to MANIFEST and return new manifest. | |
220 | Remove MANIFEST entries that have the same name and output as ENTRIES." | |
221 | (define (same-entry? entry name output) | |
222 | (match entry | |
223 | (($ <manifest-entry> entry-name _ entry-output _ ...) | |
224 | (and (equal? name entry-name) | |
225 | (equal? output entry-output))))) | |
226 | ||
227 | (make-manifest | |
228 | (append entries | |
229 | (fold (lambda (entry result) | |
230 | (match entry | |
231 | (($ <manifest-entry> name _ out _ ...) | |
232 | (filter (negate (cut same-entry? <> name out)) | |
233 | result)))) | |
234 | (manifest-entries manifest) | |
235 | entries)))) | |
236 | ||
a2078770 LC |
237 | (define (manifest-installed? manifest pattern) |
238 | "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), | |
239 | #f otherwise." | |
240 | (->bool (find (entry-predicate pattern) | |
cc4ecc2d LC |
241 | (manifest-entries manifest)))) |
242 | ||
a2078770 LC |
243 | (define (manifest-matching-entries manifest patterns) |
244 | "Return all the entries of MANIFEST that match one of the PATTERNS." | |
245 | (define predicates | |
246 | (map entry-predicate patterns)) | |
247 | ||
248 | (define (matches? entry) | |
249 | (any (lambda (pred) | |
250 | (pred entry)) | |
251 | predicates)) | |
252 | ||
253 | (filter matches? (manifest-entries manifest))) | |
254 | ||
cc4ecc2d | 255 | \f |
343745c8 AK |
256 | ;;; |
257 | ;;; Manifest transactions. | |
258 | ;;; | |
259 | ||
260 | (define-record-type* <manifest-transaction> manifest-transaction | |
261 | make-manifest-transaction | |
262 | manifest-transaction? | |
263 | (install manifest-transaction-install ; list of <manifest-entry> | |
264 | (default '())) | |
265 | (remove manifest-transaction-remove ; list of <manifest-pattern> | |
266 | (default '()))) | |
267 | ||
268 | (define (manifest-perform-transaction manifest transaction) | |
269 | "Perform TRANSACTION on MANIFEST and return new manifest." | |
270 | (let ((install (manifest-transaction-install transaction)) | |
271 | (remove (manifest-transaction-remove transaction))) | |
272 | (manifest-add (manifest-remove manifest remove) | |
273 | install))) | |
274 | ||
275 | (define* (manifest-show-transaction store manifest transaction | |
276 | #:key dry-run?) | |
277 | "Display what will/would be installed/removed from MANIFEST by TRANSACTION." | |
6b74bb0a AK |
278 | (define (package-strings name version output item) |
279 | (map (lambda (name version output item) | |
280 | (format #f " ~a-~a\t~a\t~a" name version output | |
281 | (if (package? item) | |
282 | (package-output store item output) | |
283 | item))) | |
284 | name version output item)) | |
285 | ||
286 | (let* ((remove (manifest-matching-entries | |
287 | manifest (manifest-transaction-remove transaction))) | |
288 | (install/upgrade (manifest-transaction-install transaction)) | |
289 | (install '()) | |
290 | (upgrade (append-map | |
291 | (lambda (entry) | |
292 | (let ((matching | |
293 | (manifest-matching-entries | |
294 | manifest | |
295 | (list (manifest-pattern | |
296 | (name (manifest-entry-name entry)) | |
297 | (output (manifest-entry-output entry))))))) | |
298 | (when (null? matching) | |
299 | (set! install (cons entry install))) | |
300 | matching)) | |
301 | install/upgrade))) | |
343745c8 | 302 | (match remove |
6b74bb0a | 303 | ((($ <manifest-entry> name version output item _) ..1) |
343745c8 | 304 | (let ((len (length name)) |
6b74bb0a | 305 | (remove (package-strings name version output item))) |
343745c8 AK |
306 | (if dry-run? |
307 | (format (current-error-port) | |
308 | (N_ "The following package would be removed:~%~{~a~%~}~%" | |
309 | "The following packages would be removed:~%~{~a~%~}~%" | |
310 | len) | |
311 | remove) | |
312 | (format (current-error-port) | |
313 | (N_ "The following package will be removed:~%~{~a~%~}~%" | |
314 | "The following packages will be removed:~%~{~a~%~}~%" | |
315 | len) | |
316 | remove)))) | |
317 | (_ #f)) | |
6b74bb0a AK |
318 | (match upgrade |
319 | ((($ <manifest-entry> name version output item _) ..1) | |
320 | (let ((len (length name)) | |
321 | (upgrade (package-strings name version output item))) | |
322 | (if dry-run? | |
323 | (format (current-error-port) | |
324 | (N_ "The following package would be upgraded:~%~{~a~%~}~%" | |
325 | "The following packages would be upgraded:~%~{~a~%~}~%" | |
326 | len) | |
327 | upgrade) | |
328 | (format (current-error-port) | |
329 | (N_ "The following package will be upgraded:~%~{~a~%~}~%" | |
330 | "The following packages will be upgraded:~%~{~a~%~}~%" | |
331 | len) | |
332 | upgrade)))) | |
333 | (_ #f)) | |
343745c8 AK |
334 | (match install |
335 | ((($ <manifest-entry> name version output item _) ..1) | |
336 | (let ((len (length name)) | |
6b74bb0a | 337 | (install (package-strings name version output item))) |
343745c8 AK |
338 | (if dry-run? |
339 | (format (current-error-port) | |
340 | (N_ "The following package would be installed:~%~{~a~%~}~%" | |
341 | "The following packages would be installed:~%~{~a~%~}~%" | |
342 | len) | |
343 | install) | |
344 | (format (current-error-port) | |
345 | (N_ "The following package will be installed:~%~{~a~%~}~%" | |
346 | "The following packages will be installed:~%~{~a~%~}~%" | |
347 | len) | |
348 | install)))) | |
349 | (_ #f)))) | |
350 | ||
351 | \f | |
cc4ecc2d LC |
352 | ;;; |
353 | ;;; Profiles. | |
354 | ;;; | |
355 | ||
a54c94a4 | 356 | (define (profile-derivation manifest) |
cc4ecc2d LC |
357 | "Return a derivation that builds a profile (aka. 'user environment') with |
358 | the given MANIFEST." | |
a54c94a4 LC |
359 | (define inputs |
360 | (append-map (match-lambda | |
361 | (($ <manifest-entry> name version | |
4ca0b410 LC |
362 | output (? package? package) deps) |
363 | `((,package ,output) ,@deps)) | |
a54c94a4 LC |
364 | (($ <manifest-entry> name version output path deps) |
365 | ;; Assume PATH and DEPS are already valid. | |
4ca0b410 | 366 | `(,path ,@deps))) |
a54c94a4 LC |
367 | (manifest-entries manifest))) |
368 | ||
cc4ecc2d | 369 | (define builder |
a54c94a4 LC |
370 | #~(begin |
371 | (use-modules (ice-9 pretty-print) | |
372 | (guix build union)) | |
373 | ||
374 | (setvbuf (current-output-port) _IOLBF) | |
375 | (setvbuf (current-error-port) _IOLBF) | |
376 | ||
4ca0b410 LC |
377 | (union-build #$output '#$inputs |
378 | #:log-port (%make-void-port "w")) | |
379 | (call-with-output-file (string-append #$output "/manifest") | |
380 | (lambda (p) | |
381 | (pretty-print '#$(manifest->gexp manifest) p))))) | |
a54c94a4 LC |
382 | |
383 | (gexp->derivation "profile" builder | |
384 | #:modules '((guix build union)) | |
385 | #:local-build? #t)) | |
cc4ecc2d LC |
386 | |
387 | (define (profile-regexp profile) | |
388 | "Return a regular expression that matches PROFILE's name and number." | |
389 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
390 | "-([0-9]+)"))) | |
391 | ||
392 | (define (generation-number profile) | |
393 | "Return PROFILE's number or 0. An absolute file name must be used." | |
394 | (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) | |
395 | (basename (readlink profile)))) | |
396 | (compose string->number (cut match:substring <> 1))) | |
397 | 0)) | |
398 | ||
399 | (define (generation-numbers profile) | |
400 | "Return the sorted list of generation numbers of PROFILE, or '(0) if no | |
401 | former profiles were found." | |
402 | (define* (scandir name #:optional (select? (const #t)) | |
403 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
404 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
405 | (define (enter? dir stat result) | |
406 | (and stat (string=? dir name))) | |
407 | ||
408 | (define (visit basename result) | |
409 | (if (select? basename) | |
410 | (cons basename result) | |
411 | result)) | |
412 | ||
413 | (define (leaf name stat result) | |
414 | (and result | |
415 | (visit (basename name) result))) | |
416 | ||
417 | (define (down name stat result) | |
418 | (visit "." '())) | |
419 | ||
420 | (define (up name stat result) | |
421 | (visit ".." result)) | |
422 | ||
423 | (define (skip name stat result) | |
424 | ;; All the sub-directories are skipped. | |
425 | (visit (basename name) result)) | |
426 | ||
427 | (define (error name* stat errno result) | |
428 | (if (string=? name name*) ; top-level NAME is unreadable | |
429 | result | |
430 | (visit (basename name*) result))) | |
431 | ||
432 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
433 | (lambda (files) | |
434 | (sort files entry<?)))) | |
435 | ||
436 | (match (scandir (dirname profile) | |
437 | (cute regexp-exec (profile-regexp profile) <>)) | |
438 | (#f ; no profile directory | |
439 | '(0)) | |
440 | (() ; no profiles | |
441 | '(0)) | |
442 | ((profiles ...) ; former profiles around | |
443 | (sort (map (compose string->number | |
444 | (cut match:substring <> 1) | |
445 | (cute regexp-exec (profile-regexp profile) <>)) | |
446 | profiles) | |
447 | <)))) | |
448 | ||
449 | (define (previous-generation-number profile number) | |
450 | "Return the number of the generation before generation NUMBER of | |
451 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
452 | case when generations have been deleted (there are \"holes\")." | |
453 | (fold (lambda (candidate highest) | |
454 | (if (and (< candidate number) (> candidate highest)) | |
455 | candidate | |
456 | highest)) | |
457 | 0 | |
458 | (generation-numbers profile))) | |
459 | ||
460 | (define (generation-file-name profile generation) | |
461 | "Return the file name for PROFILE's GENERATION." | |
462 | (format #f "~a-~a-link" profile generation)) | |
463 | ||
464 | (define (generation-time profile number) | |
465 | "Return the creation time of a generation in the UTC format." | |
466 | (make-time time-utc 0 | |
467 | (stat:ctime (stat (generation-file-name profile number))))) | |
468 | ||
469 | ;;; profiles.scm ends here |