2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
5 datarootdir
="@datarootdir@"
7 GUILE_LOAD_COMPILED_PATH
="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
8 export GUILE_LOAD_COMPILED_PATH
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)))" "$@"
14 ;;; Guix
--- Nix package management from Guile.
-*- coding
: utf-8
-*-
15 ;;; Copyright
(C
) 2012 Ludovic Courtès
<ludo@gnu.org
>
17 ;;; This
file is part of Guix.
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.
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.
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
/>.
32 (define-module
(guix-package
)
33 #:use-module (guix ui)
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)
48 #:use-module (distro packages guile)
49 #:export (guix-package))
59 (define
%user-environment-directory
60 (and
=> (getenv
"HOME")
61 (cut string-append
<> "/.guix-profile")))
63 (define
%profile-directory
64 (string-append
"/nix/var/nix/profiles/"
66 (or
(and
=> (getenv
"USER")
67 (cut string-append
"per-user/" <>))
70 (define
%current-profile
71 (string-append
%profile-directory
"/profile"))
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 ())))))
80 (define (manifest-packages manifest)
81 "Return the packages listed in MANIFEST."
83 (('manifest
('version 0) ('packages packages
))
86 (error
"unsupported manifest format" manifest
))))
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."
92 (make-regexp
(string-append
"^" (regexp-quote
(basename profile
))
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
)))
101 (define
(visit
basename result
)
102 (if (select?
basename)
103 (cons
basename result
)
106 (define
(leaf name stat result
)
108 (visit
(basename name
) result
)))
110 (define
(down name stat result
)
113 (define (up name stat result)
116 (define (skip name stat result)
117 ;; All the sub-directories are skipped.
118 (visit (basename name) result))
120 (define (error name* stat errno result)
121 (if (string=? name name*) ; top-level NAME is unreadable
123 (visit (basename name*) result)))
125 (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
127 (sort files entry<?))))
129 (match (scandir (dirname profile)
130 (cut regexp-exec %profile-rx <>))
131 (#f ; no profile directory
135 ((profiles ...) ; former profiles around
136 (let ((numbers (map (compose string->number
137 (cut match:substring <> 1)
138 (cut regexp-exec %profile-rx <>))
140 (fold (lambda (number highest)
141 (if (> number highest)
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."
152 (use-modules (ice-9 pretty-print)
155 (setvbuf (current-output-port) _IOLBF)
156 (setvbuf (current-error-port) _IOLBF)
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
")
165 (pretty-print '(manifest (version 0)
166 (packages ,packages))
169 (build-expression->derivation store "user-environment
"
173 ((name version output path)
176 #:modules '((guix build union))))
180 ;;; Command-line options.
183 (define %default-options
184 ;; Alist of default option values.
185 `((profile . ,%current-profile)))
188 (display (_ "Usage
: guix-package
[OPTION
]... PACKAGES...
189 Install
, remove
, or upgrade PACKAGES
in a single transaction.
\n"))
191 -i, --install=PACKAGE
install PACKAGE
"))
193 -r, --remove=PACKAGE remove PACKAGE
"))
195 -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP
"))
198 -p, --profile=PROFILE use PROFILE instead of the user
's default profile"))
200 -n, --dry-run show what would be done without actually doing it"))
202 -b, --bootstrap use the bootstrap Guile to build the profile"))
205 -I, --list-installed[=REGEXP]
206 list installed packages matching REGEXP"))
208 -A, --list-available[=REGEXP]
209 list available packages matching REGEXP"))
212 -h, --help display this help and exit"))
214 -V, --version display version information and exit"))
217 Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
220 ;; Specification of the command-line options.
221 (list (option '(#\h "help") #f #f
225 (option
'(#\V "version") #f #f
227 (show-version-and-exit "guix-package")))
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)
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 ""))
249 (option '(#\A "list-available") #f #t
250 (lambda
(opt name arg result
)
251 (cons
`(query list-available ,(or arg ""))
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))
266 (alist-cons 'argument arg result))
269 (define (show-what-to-build drv dry-run?)
270 ;; Show what will/would be built in realizing the derivations listed
272 (let* ((req (append-map (lambda (drv-path)
273 (let ((d (call-with-input-file drv-path
275 (derivation-prerequisites-to-build %store d)))
277 (req* (delete-duplicates
278 (append (remove (compose (cut valid-path? %store <>)
279 derivation-path->output-path)
281 (map derivation-input-path req)))))
283 (format (current-error-port)
284 (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
285 "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
288 (format (current-error-port)
289 (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
290 "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
292 (null? req*) req*))))
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)
299 (let*-values (((name sub-drv)
300 (match (string-rindex name #\:)
301 (#f (values name "out"))
302 (colon (values (substring name 0 colon)
303 (substring name (+ 1 colon))))))
305 (package-name->name+version name)))
306 (match (find-packages-by-name name version)
308 (list name (package-version p) sub-drv p))
310 (format (current-error-port)
311 (_ "warning: ambiguous package specification `~a
'~%")
313 (format (current-error-port)
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))
319 (leave (_ "~a: package not found~%") request)))))
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?
))
328 (('install . package)
329 (find-package package))
332 (drv (filter-map (match-lambda
333 ((name version sub-drv
334 (? package? package))
335 (package-derivation %store package))
339 (filter-map (match-lambda
340 (('install .
(? store-path? path
))
341 (let-values
(((name version
)
342 (package-name-
>name
+version
343 (store-path-package-name
345 `(,name ,version #f ,path)))
348 (map (lambda (tuple drv)
350 ((name version sub-drv _)
352 (derivation-path->output-path
354 `(,name
,version
,sub-drv
,output-path
)))))
356 (remove
(filter-map
(match-lambda
361 (packages (append install*
364 (profile-manifest profile))
367 (show-what-to-build drv 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"
376 (basename profile) (+ 1 number))))
377 (and (build-derivations %store (list prof-drv))
380 (when (file-exists? profile)
381 (delete-file profile))
382 (symlink name profile))))))))
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
))))
401 (('list-available regexp)
402 (let* ((regexp (and regexp (make-regexp regexp)))
403 (available (fold-packages
405 (let ((n (package-name p)))
407 (if (regexp-exec regexp n)
412 (for-each
(lambda
(p
)
413 (format
#t "~a\t~a\t~a~%"
416 (location-
>string
(package-location p
))))
419 (string
<?
(package-name p1
)
420 (package-name p2
)))))
424 (setlocale LC_ALL
"")
426 (setvbuf
(current-output-port
) _IOLBF
)
427 (setvbuf
(current-error-port
) _IOLBF
)
429 (let ((opts
(parse-options
)))
431 (or
(process-query opts
)
432 (parameterize
((%guile-for-build
433 (package-derivation
%store
434 (if (assoc-ref opts
'bootstrap?)
435 (@@ (distro packages base)
438 (process-actions opts))))))
441 ;; eval: (put 'guard
'scheme-indent-function 1)