Commit | Line | Data |
---|---|---|
cc4ecc2d | 1 | ;;; GNU Guix --- Functional package management for GNU |
9e55f04a | 2 | ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> |
cc4ecc2d LC |
3 | ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> |
4 | ;;; | |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (guix profiles) | |
21 | #:use-module (guix utils) | |
22 | #:use-module (guix records) | |
23 | #:use-module (guix derivations) | |
24 | #:use-module (guix packages) | |
a54c94a4 | 25 | #:use-module (guix gexp) |
cc4ecc2d LC |
26 | #:use-module (ice-9 match) |
27 | #:use-module (ice-9 regex) | |
28 | #:use-module (ice-9 ftw) | |
29 | #:use-module (srfi srfi-1) | |
30 | #:use-module (srfi srfi-9) | |
31 | #:use-module (srfi srfi-19) | |
32 | #:use-module (srfi srfi-26) | |
33 | #:export (manifest make-manifest | |
34 | manifest? | |
35 | manifest-entries | |
36 | ||
37 | <manifest-entry> ; FIXME: eventually make it internal | |
38 | manifest-entry | |
39 | manifest-entry? | |
40 | manifest-entry-name | |
41 | manifest-entry-version | |
42 | manifest-entry-output | |
a54c94a4 | 43 | manifest-entry-item |
cc4ecc2d LC |
44 | manifest-entry-dependencies |
45 | ||
a2078770 LC |
46 | manifest-pattern |
47 | manifest-pattern? | |
48 | ||
cc4ecc2d | 49 | manifest-remove |
f7554030 | 50 | manifest-add |
cc4ecc2d | 51 | manifest-installed? |
a2078770 | 52 | manifest-matching-entries |
cc4ecc2d LC |
53 | |
54 | profile-manifest | |
462f5cca | 55 | package->manifest-entry |
cc4ecc2d LC |
56 | profile-derivation |
57 | generation-number | |
58 | generation-numbers | |
59 | previous-generation-number | |
60 | generation-time | |
61 | generation-file-name)) | |
62 | ||
63 | ;;; Commentary: | |
64 | ;;; | |
65 | ;;; Tools to create and manipulate profiles---i.e., the representation of a | |
66 | ;;; set of installed packages. | |
67 | ;;; | |
68 | ;;; Code: | |
69 | ||
70 | \f | |
71 | ;;; | |
72 | ;;; Manifests. | |
73 | ;;; | |
74 | ||
75 | (define-record-type <manifest> | |
76 | (manifest entries) | |
77 | manifest? | |
78 | (entries manifest-entries)) ; list of <manifest-entry> | |
79 | ||
80 | ;; Convenient alias, to avoid name clashes. | |
81 | (define make-manifest manifest) | |
82 | ||
83 | (define-record-type* <manifest-entry> manifest-entry | |
84 | make-manifest-entry | |
85 | manifest-entry? | |
86 | (name manifest-entry-name) ; string | |
87 | (version manifest-entry-version) ; string | |
88 | (output manifest-entry-output ; string | |
89 | (default "out")) | |
a54c94a4 | 90 | (item manifest-entry-item) ; package | store path |
4ca0b410 LC |
91 | (dependencies manifest-entry-dependencies ; (store path | package)* |
92 | (default '()))) | |
cc4ecc2d | 93 | |
a2078770 LC |
94 | (define-record-type* <manifest-pattern> manifest-pattern |
95 | make-manifest-pattern | |
96 | manifest-pattern? | |
97 | (name manifest-pattern-name) ; string | |
98 | (version manifest-pattern-version ; string | #f | |
99 | (default #f)) | |
100 | (output manifest-pattern-output ; string | #f | |
101 | (default "out"))) | |
102 | ||
cc4ecc2d LC |
103 | (define (profile-manifest profile) |
104 | "Return the PROFILE's manifest." | |
105 | (let ((file (string-append profile "/manifest"))) | |
106 | (if (file-exists? file) | |
107 | (call-with-input-file file read-manifest) | |
108 | (manifest '())))) | |
109 | ||
462f5cca LC |
110 | (define* (package->manifest-entry package #:optional output) |
111 | "Return a manifest entry for the OUTPUT of package PACKAGE. When OUTPUT is | |
112 | omitted or #f, use the first output of PACKAGE." | |
113 | (let ((deps (map (match-lambda | |
114 | ((label package) | |
115 | `(,package "out")) | |
116 | ((label package output) | |
117 | `(,package ,output))) | |
118 | (package-transitive-propagated-inputs package)))) | |
119 | (manifest-entry | |
120 | (name (package-name package)) | |
121 | (version (package-version package)) | |
122 | (output (or output (car (package-outputs package)))) | |
123 | (item package) | |
124 | (dependencies (delete-duplicates deps))))) | |
125 | ||
a54c94a4 LC |
126 | (define (manifest->gexp manifest) |
127 | "Return a representation of MANIFEST as a gexp." | |
128 | (define (entry->gexp entry) | |
cc4ecc2d | 129 | (match entry |
a54c94a4 LC |
130 | (($ <manifest-entry> name version output (? string? path) (deps ...)) |
131 | #~(#$name #$version #$output #$path #$deps)) | |
132 | (($ <manifest-entry> name version output (? package? package) (deps ...)) | |
133 | #~(#$name #$version #$output | |
134 | (ungexp package (or output "out")) #$deps)))) | |
cc4ecc2d LC |
135 | |
136 | (match manifest | |
137 | (($ <manifest> (entries ...)) | |
a54c94a4 LC |
138 | #~(manifest (version 1) |
139 | (packages #$(map entry->gexp entries)))))) | |
cc4ecc2d LC |
140 | |
141 | (define (sexp->manifest sexp) | |
142 | "Parse SEXP as a manifest." | |
143 | (match sexp | |
144 | (('manifest ('version 0) | |
145 | ('packages ((name version output path) ...))) | |
146 | (manifest | |
147 | (map (lambda (name version output path) | |
148 | (manifest-entry | |
149 | (name name) | |
150 | (version version) | |
151 | (output output) | |
a54c94a4 | 152 | (item path))) |
cc4ecc2d LC |
153 | name version output path))) |
154 | ||
155 | ;; Version 1 adds a list of propagated inputs to the | |
156 | ;; name/version/output/path tuples. | |
157 | (('manifest ('version 1) | |
158 | ('packages ((name version output path deps) ...))) | |
159 | (manifest | |
160 | (map (lambda (name version output path deps) | |
d34736c5 LC |
161 | ;; Up to Guix 0.7 included, dependencies were listed as ("gmp" |
162 | ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in | |
163 | ;; such lists. | |
164 | (let ((deps (match deps | |
165 | (((labels directories) ...) | |
166 | directories) | |
167 | ((directories ...) | |
168 | directories)))) | |
169 | (manifest-entry | |
170 | (name name) | |
171 | (version version) | |
172 | (output output) | |
173 | (item path) | |
174 | (dependencies deps)))) | |
cc4ecc2d LC |
175 | name version output path deps))) |
176 | ||
177 | (_ | |
178 | (error "unsupported manifest format" manifest)))) | |
179 | ||
180 | (define (read-manifest port) | |
181 | "Return the packages listed in MANIFEST." | |
182 | (sexp->manifest (read port))) | |
183 | ||
a2078770 LC |
184 | (define (entry-predicate pattern) |
185 | "Return a procedure that returns #t when passed a manifest entry that | |
186 | matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they | |
187 | are ignored." | |
188 | (match pattern | |
189 | (($ <manifest-pattern> name version output) | |
190 | (match-lambda | |
191 | (($ <manifest-entry> entry-name entry-version entry-output) | |
192 | (and (string=? entry-name name) | |
193 | (or (not entry-output) (not output) | |
194 | (string=? entry-output output)) | |
195 | (or (not version) | |
196 | (string=? entry-version version)))))))) | |
197 | ||
198 | (define (manifest-remove manifest patterns) | |
199 | "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS | |
200 | must be a manifest-pattern." | |
201 | (define (remove-entry pattern lst) | |
202 | (remove (entry-predicate pattern) lst)) | |
203 | ||
204 | (make-manifest (fold remove-entry | |
cc4ecc2d | 205 | (manifest-entries manifest) |
a2078770 | 206 | patterns))) |
cc4ecc2d | 207 | |
f7554030 AK |
208 | (define (manifest-add manifest entries) |
209 | "Add a list of manifest ENTRIES to MANIFEST and return new manifest. | |
210 | Remove MANIFEST entries that have the same name and output as ENTRIES." | |
211 | (define (same-entry? entry name output) | |
212 | (match entry | |
213 | (($ <manifest-entry> entry-name _ entry-output _ ...) | |
214 | (and (equal? name entry-name) | |
215 | (equal? output entry-output))))) | |
216 | ||
217 | (make-manifest | |
218 | (append entries | |
219 | (fold (lambda (entry result) | |
220 | (match entry | |
221 | (($ <manifest-entry> name _ out _ ...) | |
222 | (filter (negate (cut same-entry? <> name out)) | |
223 | result)))) | |
224 | (manifest-entries manifest) | |
225 | entries)))) | |
226 | ||
a2078770 LC |
227 | (define (manifest-installed? manifest pattern) |
228 | "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), | |
229 | #f otherwise." | |
230 | (->bool (find (entry-predicate pattern) | |
cc4ecc2d LC |
231 | (manifest-entries manifest)))) |
232 | ||
a2078770 LC |
233 | (define (manifest-matching-entries manifest patterns) |
234 | "Return all the entries of MANIFEST that match one of the PATTERNS." | |
235 | (define predicates | |
236 | (map entry-predicate patterns)) | |
237 | ||
238 | (define (matches? entry) | |
239 | (any (lambda (pred) | |
240 | (pred entry)) | |
241 | predicates)) | |
242 | ||
243 | (filter matches? (manifest-entries manifest))) | |
244 | ||
cc4ecc2d LC |
245 | \f |
246 | ;;; | |
247 | ;;; Profiles. | |
248 | ;;; | |
249 | ||
a54c94a4 | 250 | (define (profile-derivation manifest) |
cc4ecc2d LC |
251 | "Return a derivation that builds a profile (aka. 'user environment') with |
252 | the given MANIFEST." | |
a54c94a4 LC |
253 | (define inputs |
254 | (append-map (match-lambda | |
255 | (($ <manifest-entry> name version | |
4ca0b410 LC |
256 | output (? package? package) deps) |
257 | `((,package ,output) ,@deps)) | |
a54c94a4 LC |
258 | (($ <manifest-entry> name version output path deps) |
259 | ;; Assume PATH and DEPS are already valid. | |
4ca0b410 | 260 | `(,path ,@deps))) |
a54c94a4 LC |
261 | (manifest-entries manifest))) |
262 | ||
cc4ecc2d | 263 | (define builder |
a54c94a4 LC |
264 | #~(begin |
265 | (use-modules (ice-9 pretty-print) | |
266 | (guix build union)) | |
267 | ||
268 | (setvbuf (current-output-port) _IOLBF) | |
269 | (setvbuf (current-error-port) _IOLBF) | |
270 | ||
4ca0b410 LC |
271 | (union-build #$output '#$inputs |
272 | #:log-port (%make-void-port "w")) | |
273 | (call-with-output-file (string-append #$output "/manifest") | |
274 | (lambda (p) | |
275 | (pretty-print '#$(manifest->gexp manifest) p))))) | |
a54c94a4 LC |
276 | |
277 | (gexp->derivation "profile" builder | |
278 | #:modules '((guix build union)) | |
279 | #:local-build? #t)) | |
cc4ecc2d LC |
280 | |
281 | (define (profile-regexp profile) | |
282 | "Return a regular expression that matches PROFILE's name and number." | |
283 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
284 | "-([0-9]+)"))) | |
285 | ||
286 | (define (generation-number profile) | |
287 | "Return PROFILE's number or 0. An absolute file name must be used." | |
288 | (or (and=> (false-if-exception (regexp-exec (profile-regexp profile) | |
289 | (basename (readlink profile)))) | |
290 | (compose string->number (cut match:substring <> 1))) | |
291 | 0)) | |
292 | ||
293 | (define (generation-numbers profile) | |
294 | "Return the sorted list of generation numbers of PROFILE, or '(0) if no | |
295 | former profiles were found." | |
296 | (define* (scandir name #:optional (select? (const #t)) | |
297 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
298 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
299 | (define (enter? dir stat result) | |
300 | (and stat (string=? dir name))) | |
301 | ||
302 | (define (visit basename result) | |
303 | (if (select? basename) | |
304 | (cons basename result) | |
305 | result)) | |
306 | ||
307 | (define (leaf name stat result) | |
308 | (and result | |
309 | (visit (basename name) result))) | |
310 | ||
311 | (define (down name stat result) | |
312 | (visit "." '())) | |
313 | ||
314 | (define (up name stat result) | |
315 | (visit ".." result)) | |
316 | ||
317 | (define (skip name stat result) | |
318 | ;; All the sub-directories are skipped. | |
319 | (visit (basename name) result)) | |
320 | ||
321 | (define (error name* stat errno result) | |
322 | (if (string=? name name*) ; top-level NAME is unreadable | |
323 | result | |
324 | (visit (basename name*) result))) | |
325 | ||
326 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
327 | (lambda (files) | |
328 | (sort files entry<?)))) | |
329 | ||
330 | (match (scandir (dirname profile) | |
331 | (cute regexp-exec (profile-regexp profile) <>)) | |
332 | (#f ; no profile directory | |
333 | '(0)) | |
334 | (() ; no profiles | |
335 | '(0)) | |
336 | ((profiles ...) ; former profiles around | |
337 | (sort (map (compose string->number | |
338 | (cut match:substring <> 1) | |
339 | (cute regexp-exec (profile-regexp profile) <>)) | |
340 | profiles) | |
341 | <)))) | |
342 | ||
343 | (define (previous-generation-number profile number) | |
344 | "Return the number of the generation before generation NUMBER of | |
345 | PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the | |
346 | case when generations have been deleted (there are \"holes\")." | |
347 | (fold (lambda (candidate highest) | |
348 | (if (and (< candidate number) (> candidate highest)) | |
349 | candidate | |
350 | highest)) | |
351 | 0 | |
352 | (generation-numbers profile))) | |
353 | ||
354 | (define (generation-file-name profile generation) | |
355 | "Return the file name for PROFILE's GENERATION." | |
356 | (format #f "~a-~a-link" profile generation)) | |
357 | ||
358 | (define (generation-time profile number) | |
359 | "Return the creation time of a generation in the UTC format." | |
360 | (make-time time-utc 0 | |
361 | (stat:ctime (stat (generation-file-name profile number))))) | |
362 | ||
363 | ;;; profiles.scm ends here |