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) | |
47 | #:autoload (distro) (find-packages-by-name) | |
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")) | |
207 | (newline) | |
208 | (display (_ " | |
0afdc485 LC |
209 | -h, --help display this help and exit")) |
210 | (display (_ " | |
211 | -V, --version display version information and exit")) | |
212 | (newline) | |
213 | (format #t (_ " | |
214 | Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@")) | |
215 | ||
216 | (define %options | |
217 | ;; Specification of the command-line options. | |
218 | (list (option '(#\h "help") #f #f | |
219 | (lambda args | |
220 | (show-help) | |
221 | (exit 0))) | |
222 | (option '(#\V "version") #f #f | |
223 | (lambda args | |
cdd5d6f9 | 224 | (show-version-and-exit "guix-package"))) |
0afdc485 LC |
225 | |
226 | (option '(#\i "install") #t #f | |
227 | (lambda (opt name arg result) | |
228 | (alist-cons 'install arg result))) | |
229 | (option '(#\r "remove") #t #f | |
230 | (lambda (opt name arg result) | |
231 | (alist-cons 'remove arg result))) | |
232 | (option '(#\p "profile") #t #f | |
233 | (lambda (opt name arg result) | |
234 | (alist-cons 'profile arg | |
235 | (alist-delete 'profile result)))) | |
236 | (option '(#\n "dry-run") #f #f | |
237 | (lambda (opt name arg result) | |
238 | (alist-cons 'dry-run? #t result))) | |
239 | (option '(#\b "bootstrap") #f #f | |
240 | (lambda (opt name arg result) | |
733b4130 LC |
241 | (alist-cons 'bootstrap? #t result))) |
242 | (option '(#\I "list-installed") #f #t | |
243 | (lambda (opt name arg result) | |
244 | (cons `(query list-installed ,(or arg "")) | |
245 | result))))) | |
0afdc485 LC |
246 | |
247 | \f | |
248 | ;;; | |
249 | ;;; Entry point. | |
250 | ;;; | |
251 | ||
252 | (define (guix-package . args) | |
253 | (define (parse-options) | |
254 | ;; Return the alist of option values. | |
255 | (args-fold args %options | |
256 | (lambda (opt name arg result) | |
257 | (leave (_ "~A: unrecognized option~%") name)) | |
258 | (lambda (arg result) | |
259 | (alist-cons 'argument arg result)) | |
260 | %default-options)) | |
261 | ||
262 | (define (show-what-to-build drv dry-run?) | |
263 | ;; Show what will/would be built in realizing the derivations listed | |
264 | ;; in DRV. | |
265 | (let* ((req (append-map (lambda (drv-path) | |
266 | (let ((d (call-with-input-file drv-path | |
267 | read-derivation))) | |
268 | (derivation-prerequisites-to-build %store d))) | |
269 | drv)) | |
270 | (req* (delete-duplicates | |
271 | (append (remove (compose (cut valid-path? %store <>) | |
272 | derivation-path->output-path) | |
273 | drv) | |
274 | (map derivation-input-path req))))) | |
275 | (if dry-run? | |
276 | (format (current-error-port) | |
277 | (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" | |
278 | "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" | |
279 | (length req*)) | |
280 | (null? req*) req*) | |
281 | (format (current-error-port) | |
282 | (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" | |
283 | "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" | |
284 | (length req*)) | |
285 | (null? req*) req*)))) | |
286 | ||
287 | (define (find-package name) | |
288 | ;; Find the package NAME; NAME may contain a version number and a | |
289 | ;; sub-derivation name. | |
290 | (define request name) | |
0afdc485 LC |
291 | |
292 | (let*-values (((name sub-drv) | |
293 | (match (string-rindex name #\:) | |
294 | (#f (values name "out")) | |
9518856b LC |
295 | (colon (values (substring name 0 colon) |
296 | (substring name (+ 1 colon)))))) | |
0afdc485 | 297 | ((name version) |
9b48fb88 | 298 | (package-name->name+version name))) |
0afdc485 LC |
299 | (match (find-packages-by-name name version) |
300 | ((p) | |
301 | (list name version sub-drv p)) | |
c6f09dfa | 302 | ((p p* ...) |
0afdc485 LC |
303 | (format (current-error-port) |
304 | (_ "warning: ambiguous package specification `~a'~%") | |
305 | request) | |
306 | (format (current-error-port) | |
307 | (_ "warning: choosing ~s~%") | |
308 | p) | |
309 | (list name version sub-drv p)) | |
310 | (() | |
311 | (leave (_ "~a: package not found~%") request))))) | |
312 | ||
733b4130 LC |
313 | (define (process-actions opts) |
314 | ;; Process any install/remove/upgrade action from OPTS. | |
315 | (let* ((dry-run? (assoc-ref opts 'dry-run?)) | |
316 | (profile (assoc-ref opts 'profile)) | |
317 | (install (filter-map (match-lambda | |
318 | (('install . (? store-path?)) | |
319 | #f) | |
320 | (('install . package) | |
321 | (find-package package)) | |
322 | (_ #f)) | |
323 | opts)) | |
324 | (drv (filter-map (match-lambda | |
325 | ((name version sub-drv | |
326 | (? package? package)) | |
327 | (package-derivation %store package)) | |
328 | (_ #f)) | |
329 | install)) | |
330 | (install* (append | |
331 | (filter-map (match-lambda | |
332 | (('install . (? store-path? path)) | |
333 | `(,(store-path-package-name path) | |
334 | #f #f ,path)) | |
335 | (_ #f)) | |
336 | opts) | |
337 | (map (lambda (tuple drv) | |
338 | (match tuple | |
339 | ((name version sub-drv _) | |
340 | (let ((output-path | |
341 | (derivation-path->output-path | |
342 | drv sub-drv))) | |
343 | `(,name ,version ,sub-drv ,output-path))))) | |
344 | install drv))) | |
345 | (remove (filter-map (match-lambda | |
346 | (('remove . package) | |
347 | package) | |
348 | (_ #f)) | |
349 | opts)) | |
350 | (packages (append install* | |
351 | (fold alist-delete | |
352 | (manifest-packages | |
353 | (profile-manifest profile)) | |
354 | remove)))) | |
355 | ||
356 | (show-what-to-build drv dry-run?) | |
357 | ||
358 | (or dry-run? | |
359 | (and (build-derivations %store drv) | |
360 | (let* ((prof-drv (profile-derivation %store packages)) | |
361 | (prof (derivation-path->output-path prof-drv)) | |
362 | (number (latest-profile-number profile)) | |
363 | (name (format #f "~a/~a-~a-link" | |
364 | (dirname profile) | |
365 | (basename profile) (+ 1 number)))) | |
366 | (and (build-derivations %store (list prof-drv)) | |
367 | (begin | |
368 | (symlink prof name) | |
369 | (when (file-exists? profile) | |
370 | (delete-file profile)) | |
371 | (symlink name profile)))))))) | |
372 | ||
373 | (define (process-query opts) | |
374 | ;; Process any query specified by OPTS. Return #t when a query was | |
375 | ;; actually processed, #f otherwise. | |
376 | (let ((profile (assoc-ref opts 'profile))) | |
377 | (match (assoc-ref opts 'query) | |
378 | (('list-installed regexp) | |
379 | (let* ((regexp (and regexp (make-regexp regexp))) | |
380 | (manifest (profile-manifest profile)) | |
381 | (installed (manifest-packages manifest))) | |
382 | (for-each (match-lambda | |
383 | ((name version output path) | |
384 | (when (or (not regexp) | |
385 | (regexp-exec regexp name)) | |
386 | (format #t "~a\t~a\t~a\t~a~%" | |
387 | name (or version "?") output path)))) | |
388 | installed))) | |
389 | (_ #f)))) | |
390 | ||
0afdc485 LC |
391 | (setlocale LC_ALL "") |
392 | (textdomain "guix") | |
393 | (setvbuf (current-output-port) _IOLBF) | |
394 | (setvbuf (current-error-port) _IOLBF) | |
395 | ||
396 | (let ((opts (parse-options))) | |
1275baeb | 397 | (with-error-handling |
733b4130 LC |
398 | (or (process-query opts) |
399 | (parameterize ((%guile-for-build | |
400 | (package-derivation %store | |
401 | (if (assoc-ref opts 'bootstrap?) | |
402 | (@@ (distro packages base) | |
403 | %bootstrap-guile) | |
404 | guile-2.0)))) | |
405 | (process-actions opts)))))) | |
0afdc485 LC |
406 | |
407 | ;; Local Variables: | |
408 | ;; eval: (put 'guard 'scheme-indent-function 1) | |
409 | ;; End: |