Commit | Line | Data |
---|---|---|
0afdc485 LC |
1 | #!/bin/sh |
2 | # aside from this initial boilerplate, this is actually -*- scheme -*- code | |
3 | ||
4 | prefix="@prefix@" | |
5 | datarootdir="@datarootdir@" | |
6 | ||
7 | GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" | |
8 | export GUILE_LOAD_COMPILED_PATH | |
9 | ||
10 | main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')' | |
11 | exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ | |
12 | -c "(apply $main (cdr (command-line)))" "$@" | |
13 | !# | |
14 | ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- | |
15 | ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> | |
16 | ;;; | |
17 | ;;; This file is part of Guix. | |
18 | ;;; | |
19 | ;;; Guix is free software; you can redistribute it and/or modify it | |
20 | ;;; under the terms of the GNU General Public License as published by | |
21 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
22 | ;;; your option) any later version. | |
23 | ;;; | |
24 | ;;; Guix is distributed in the hope that it will be useful, but | |
25 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
26 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
27 | ;;; GNU General Public License for more details. | |
28 | ;;; | |
29 | ;;; You should have received a copy of the GNU General Public License | |
30 | ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. | |
31 | ||
32 | (define-module (guix-package) | |
cdd5d6f9 | 33 | #:use-module (guix ui) |
0afdc485 LC |
34 | #:use-module (guix store) |
35 | #:use-module (guix derivations) | |
36 | #:use-module (guix packages) | |
37 | #:use-module (guix utils) | |
38 | #:use-module (ice-9 ftw) | |
39 | #:use-module (ice-9 format) | |
40 | #:use-module (ice-9 match) | |
41 | #:use-module (ice-9 regex) | |
42 | #:use-module (srfi srfi-1) | |
43 | #:use-module (srfi srfi-11) | |
44 | #:use-module (srfi srfi-26) | |
45 | #:use-module (srfi srfi-34) | |
46 | #:use-module (srfi srfi-37) | |
64fc89b6 | 47 | #:use-module (distro) |
1227fabb | 48 | #:use-module (distro packages guile) |
0afdc485 LC |
49 | #:export (guix-package)) |
50 | ||
0afdc485 LC |
51 | (define %store |
52 | (open-connection)) | |
53 | ||
54 | \f | |
55 | ;;; | |
56 | ;;; User environment. | |
57 | ;;; | |
58 | ||
59 | (define %user-environment-directory | |
60 | (and=> (getenv "HOME") | |
61 | (cut string-append <> "/.guix-profile"))) | |
62 | ||
63 | (define %profile-directory | |
64 | (string-append "/nix/var/nix/profiles/" | |
65 | "guix/" | |
66 | (or (and=> (getenv "USER") | |
67 | (cut string-append "per-user/" <>)) | |
68 | "default"))) | |
69 | ||
70 | (define %current-profile | |
71 | (string-append %profile-directory "/profile")) | |
72 | ||
73 | (define (profile-manifest profile) | |
74 | "Return the PROFILE's manifest." | |
75 | (let ((manifest (string-append profile "/manifest"))) | |
76 | (if (file-exists? manifest) | |
77 | (call-with-input-file manifest read) | |
78 | '(manifest (version 0) (packages ()))))) | |
79 | ||
80 | (define (manifest-packages manifest) | |
81 | "Return the packages listed in MANIFEST." | |
82 | (match manifest | |
83 | (('manifest ('version 0) ('packages packages)) | |
84 | packages) | |
85 | (_ | |
86 | (error "unsupported manifest format" manifest)))) | |
87 | ||
88 | (define (latest-profile-number profile) | |
89 | "Return the identifying number of the latest generation of PROFILE. | |
90 | PROFILE is the name of the symlink to the current generation." | |
91 | (define %profile-rx | |
92 | (make-regexp (string-append "^" (regexp-quote (basename profile)) | |
93 | "-([0-9]+)"))) | |
94 | ||
95 | (define* (scandir name #:optional (select? (const #t)) | |
96 | (entry<? (@ (ice-9 i18n) string-locale<?))) | |
97 | ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19. | |
98 | (define (enter? dir stat result) | |
99 | (and stat (string=? dir name))) | |
100 | ||
101 | (define (visit basename result) | |
102 | (if (select? basename) | |
103 | (cons basename result) | |
104 | result)) | |
105 | ||
106 | (define (leaf name stat result) | |
107 | (and result | |
108 | (visit (basename name) result))) | |
109 | ||
110 | (define (down name stat result) | |
111 | (visit "." '())) | |
112 | ||
113 | (define (up name stat result) | |
114 | (visit ".." result)) | |
115 | ||
116 | (define (skip name stat result) | |
117 | ;; All the sub-directories are skipped. | |
118 | (visit (basename name) result)) | |
119 | ||
120 | (define (error name* stat errno result) | |
121 | (if (string=? name name*) ; top-level NAME is unreadable | |
122 | result | |
123 | (visit (basename name*) result))) | |
124 | ||
125 | (and=> (file-system-fold enter? leaf down up skip error #f name lstat) | |
126 | (lambda (files) | |
127 | (sort files entry<?)))) | |
128 | ||
129 | (match (scandir (dirname profile) | |
130 | (cut regexp-exec %profile-rx <>)) | |
131 | (#f ; no profile directory | |
132 | 0) | |
133 | (() ; no profiles | |
134 | 0) | |
135 | ((profiles ...) ; former profiles around | |
136 | (let ((numbers (map (compose string->number | |
137 | (cut match:substring <> 1) | |
138 | (cut regexp-exec %profile-rx <>)) | |
139 | profiles))) | |
140 | (fold (lambda (number highest) | |
141 | (if (> number highest) | |
142 | number | |
143 | highest)) | |
144 | 0 | |
145 | numbers))))) | |
146 | ||
147 | (define (profile-derivation store packages) | |
148 | "Return a derivation that builds a profile (a user environment) with | |
149 | all of PACKAGES, a list of name/version/output/path tuples." | |
150 | (define builder | |
151 | `(begin | |
152 | (use-modules (ice-9 pretty-print) | |
153 | (guix build union)) | |
154 | ||
155 | (setvbuf (current-output-port) _IOLBF) | |
156 | (setvbuf (current-error-port) _IOLBF) | |
157 | ||
158 | (let ((output (assoc-ref %outputs "out")) | |
159 | (inputs (map cdr %build-inputs))) | |
160 | (format #t "building user environment `~a' with ~a packages...~%" | |
161 | output (length inputs)) | |
162 | (union-build output inputs) | |
163 | (call-with-output-file (string-append output "/manifest") | |
164 | (lambda (p) | |
165 | (pretty-print '(manifest (version 0) | |
166 | (packages ,packages)) | |
167 | p)))))) | |
168 | ||
169 | (build-expression->derivation store "user-environment" | |
170 | (%current-system) | |
171 | builder | |
172 | (map (match-lambda | |
173 | ((name version output path) | |
174 | `(,name ,path))) | |
175 | packages) | |
176 | #:modules '((guix build union)))) | |
177 | ||
178 | \f | |
179 | ;;; | |
180 | ;;; Command-line options. | |
181 | ;;; | |
182 | ||
183 | (define %default-options | |
184 | ;; Alist of default option values. | |
185 | `((profile . ,%current-profile))) | |
186 | ||
0afdc485 LC |
187 | (define (show-help) |
188 | (display (_ "Usage: guix-package [OPTION]... PACKAGES... | |
189 | Install, remove, or upgrade PACKAGES in a single transaction.\n")) | |
190 | (display (_ " | |
191 | -i, --install=PACKAGE install PACKAGE")) | |
192 | (display (_ " | |
193 | -r, --remove=PACKAGE remove PACKAGE")) | |
194 | (display (_ " | |
195 | -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) | |
196 | (newline) | |
197 | (display (_ " | |
198 | -p, --profile=PROFILE use PROFILE instead of the user's default profile")) | |
199 | (display (_ " | |
200 | -n, --dry-run show what would be done without actually doing it")) | |
201 | (display (_ " | |
202 | -b, --bootstrap use the bootstrap Guile to build the profile")) | |
203 | (newline) | |
204 | (display (_ " | |
733b4130 LC |
205 | -I, --list-installed[=REGEXP] |
206 | list installed packages matching REGEXP")) | |
64fc89b6 LC |
207 | (display (_ " |
208 | -A, --list-available[=REGEXP] | |
209 | list available packages matching REGEXP")) | |
733b4130 LC |
210 | (newline) |
211 | (display (_ " | |
0afdc485 LC |
212 | -h, --help display this help and exit")) |
213 | (display (_ " | |
214 | -V, --version display version information and exit")) | |
215 | (newline) | |
216 | (format #t (_ " | |
217 | Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@")) | |
218 | ||
219 | (define %options | |
220 | ;; Specification of the command-line options. | |
221 | (list (option '(#\h "help") #f #f | |
222 | (lambda args | |
223 | (show-help) | |
224 | (exit 0))) | |
225 | (option '(#\V "version") #f #f | |
226 | (lambda args | |
cdd5d6f9 | 227 | (show-version-and-exit "guix-package"))) |
0afdc485 LC |
228 | |
229 | (option '(#\i "install") #t #f | |
230 | (lambda (opt name arg result) | |
231 | (alist-cons 'install arg result))) | |
232 | (option '(#\r "remove") #t #f | |
233 | (lambda (opt name arg result) | |
234 | (alist-cons 'remove arg result))) | |
235 | (option '(#\p "profile") #t #f | |
236 | (lambda (opt name arg result) | |
237 | (alist-cons 'profile arg | |
238 | (alist-delete 'profile result)))) | |
239 | (option '(#\n "dry-run") #f #f | |
240 | (lambda (opt name arg result) | |
241 | (alist-cons 'dry-run? #t result))) | |
242 | (option '(#\b "bootstrap") #f #f | |
243 | (lambda (opt name arg result) | |
733b4130 LC |
244 | (alist-cons 'bootstrap? #t result))) |
245 | (option '(#\I "list-installed") #f #t | |
246 | (lambda (opt name arg result) | |
247 | (cons `(query list-installed ,(or arg "")) | |
64fc89b6 LC |
248 | result))) |
249 | (option '(#\A "list-available") #f #t | |
250 | (lambda (opt name arg result) | |
251 | (cons `(query list-available ,(or arg "")) | |
733b4130 | 252 | result))))) |
0afdc485 LC |
253 | |
254 | \f | |
255 | ;;; | |
256 | ;;; Entry point. | |
257 | ;;; | |
258 | ||
259 | (define (guix-package . args) | |
260 | (define (parse-options) | |
261 | ;; Return the alist of option values. | |
262 | (args-fold args %options | |
263 | (lambda (opt name arg result) | |
264 | (leave (_ "~A: unrecognized option~%") name)) | |
265 | (lambda (arg result) | |
266 | (alist-cons 'argument arg result)) | |
267 | %default-options)) | |
268 | ||
269 | (define (show-what-to-build drv dry-run?) | |
270 | ;; Show what will/would be built in realizing the derivations listed | |
271 | ;; in DRV. | |
272 | (let* ((req (append-map (lambda (drv-path) | |
273 | (let ((d (call-with-input-file drv-path | |
274 | read-derivation))) | |
275 | (derivation-prerequisites-to-build %store d))) | |
276 | drv)) | |
277 | (req* (delete-duplicates | |
278 | (append (remove (compose (cut valid-path? %store <>) | |
279 | derivation-path->output-path) | |
280 | drv) | |
281 | (map derivation-input-path req))))) | |
282 | (if dry-run? | |
283 | (format (current-error-port) | |
284 | (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" | |
285 | "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" | |
286 | (length req*)) | |
287 | (null? req*) req*) | |
288 | (format (current-error-port) | |
289 | (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" | |
290 | "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" | |
291 | (length req*)) | |
292 | (null? req*) req*)))) | |
293 | ||
294 | (define (find-package name) | |
295 | ;; Find the package NAME; NAME may contain a version number and a | |
296 | ;; sub-derivation name. | |
297 | (define request name) | |
0afdc485 LC |
298 | |
299 | (let*-values (((name sub-drv) | |
300 | (match (string-rindex name #\:) | |
301 | (#f (values name "out")) | |
9518856b LC |
302 | (colon (values (substring name 0 colon) |
303 | (substring name (+ 1 colon)))))) | |
0afdc485 | 304 | ((name version) |
9b48fb88 | 305 | (package-name->name+version name))) |
0afdc485 LC |
306 | (match (find-packages-by-name name version) |
307 | ((p) | |
d9d05363 | 308 | (list name (package-version p) sub-drv p)) |
c6f09dfa | 309 | ((p p* ...) |
0afdc485 LC |
310 | (format (current-error-port) |
311 | (_ "warning: ambiguous package specification `~a'~%") | |
312 | request) | |
313 | (format (current-error-port) | |
d9d05363 LC |
314 | (_ "warning: choosing ~a from ~a~%") |
315 | (package-full-name p) | |
316 | (location->string (package-location p))) | |
317 | (list name (package-version p) sub-drv p)) | |
0afdc485 LC |
318 | (() |
319 | (leave (_ "~a: package not found~%") request))))) | |
320 | ||
733b4130 LC |
321 | (define (process-actions opts) |
322 | ;; Process any install/remove/upgrade action from OPTS. | |
323 | (let* ((dry-run? (assoc-ref opts 'dry-run?)) | |
324 | (profile (assoc-ref opts 'profile)) | |
325 | (install (filter-map (match-lambda | |
326 | (('install . (? store-path?)) | |
327 | #f) | |
328 | (('install . package) | |
329 | (find-package package)) | |
330 | (_ #f)) | |
331 | opts)) | |
332 | (drv (filter-map (match-lambda | |
333 | ((name version sub-drv | |
334 | (? package? package)) | |
335 | (package-derivation %store package)) | |
336 | (_ #f)) | |
337 | install)) | |
338 | (install* (append | |
339 | (filter-map (match-lambda | |
340 | (('install . (? store-path? path)) | |
5075e283 LC |
341 | (let-values (((name version) |
342 | (package-name->name+version | |
343 | (store-path-package-name | |
344 | path)))) | |
345 | `(,name ,version #f ,path))) | |
733b4130 LC |
346 | (_ #f)) |
347 | opts) | |
348 | (map (lambda (tuple drv) | |
349 | (match tuple | |
350 | ((name version sub-drv _) | |
351 | (let ((output-path | |
352 | (derivation-path->output-path | |
353 | drv sub-drv))) | |
354 | `(,name ,version ,sub-drv ,output-path))))) | |
355 | install drv))) | |
356 | (remove (filter-map (match-lambda | |
357 | (('remove . package) | |
358 | package) | |
359 | (_ #f)) | |
360 | opts)) | |
361 | (packages (append install* | |
362 | (fold alist-delete | |
363 | (manifest-packages | |
364 | (profile-manifest profile)) | |
365 | remove)))) | |
366 | ||
367 | (show-what-to-build drv dry-run?) | |
368 | ||
369 | (or dry-run? | |
370 | (and (build-derivations %store drv) | |
371 | (let* ((prof-drv (profile-derivation %store packages)) | |
372 | (prof (derivation-path->output-path prof-drv)) | |
373 | (number (latest-profile-number profile)) | |
374 | (name (format #f "~a/~a-~a-link" | |
375 | (dirname profile) | |
376 | (basename profile) (+ 1 number)))) | |
377 | (and (build-derivations %store (list prof-drv)) | |
378 | (begin | |
379 | (symlink prof name) | |
380 | (when (file-exists? profile) | |
381 | (delete-file profile)) | |
382 | (symlink name profile)))))))) | |
383 | ||
384 | (define (process-query opts) | |
385 | ;; Process any query specified by OPTS. Return #t when a query was | |
386 | ;; actually processed, #f otherwise. | |
387 | (let ((profile (assoc-ref opts 'profile))) | |
388 | (match (assoc-ref opts 'query) | |
389 | (('list-installed regexp) | |
390 | (let* ((regexp (and regexp (make-regexp regexp))) | |
391 | (manifest (profile-manifest profile)) | |
392 | (installed (manifest-packages manifest))) | |
393 | (for-each (match-lambda | |
394 | ((name version output path) | |
395 | (when (or (not regexp) | |
396 | (regexp-exec regexp name)) | |
397 | (format #t "~a\t~a\t~a\t~a~%" | |
398 | name (or version "?") output path)))) | |
64fc89b6 LC |
399 | installed) |
400 | #t)) | |
401 | (('list-available regexp) | |
402 | (let* ((regexp (and regexp (make-regexp regexp))) | |
403 | (available (fold-packages | |
404 | (lambda (p r) | |
405 | (let ((n (package-name p))) | |
406 | (if regexp | |
407 | (if (regexp-exec regexp n) | |
408 | (cons p r) | |
409 | r) | |
410 | (cons p r)))) | |
411 | '()))) | |
412 | (for-each (lambda (p) | |
413 | (format #t "~a\t~a\t~a~%" | |
414 | (package-name p) | |
415 | (package-version p) | |
416 | (location->string (package-location p)))) | |
417 | (sort available | |
418 | (lambda (p1 p2) | |
419 | (string<? (package-name p1) | |
420 | (package-name p2))))) | |
421 | #t)) | |
733b4130 LC |
422 | (_ #f)))) |
423 | ||
0afdc485 LC |
424 | (setlocale LC_ALL "") |
425 | (textdomain "guix") | |
426 | (setvbuf (current-output-port) _IOLBF) | |
427 | (setvbuf (current-error-port) _IOLBF) | |
428 | ||
429 | (let ((opts (parse-options))) | |
1275baeb | 430 | (with-error-handling |
733b4130 LC |
431 | (or (process-query opts) |
432 | (parameterize ((%guile-for-build | |
433 | (package-derivation %store | |
434 | (if (assoc-ref opts 'bootstrap?) | |
435 | (@@ (distro packages base) | |
436 | %bootstrap-guile) | |
437 | guile-2.0)))) | |
438 | (process-actions opts)))))) | |
0afdc485 LC |
439 | |
440 | ;; Local Variables: | |
441 | ;; eval: (put 'guard 'scheme-indent-function 1) | |
442 | ;; End: |