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)
47 #:autoload (distro) (find-packages-by-name)
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 -h, --help display this help and exit"))
207 -V, --version display version information and exit"))
210 Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
213 ;; Specification of the command-line options.
214 (list (option '(#\h "help") #f #f
218 (option
'(#\V "version") #f #f
220 (show-version-and-exit "guix-package")))
222 (option '(#\i "install") #t #f
223 (lambda
(opt name arg result
)
224 (alist-cons
'install arg result)))
225 (option '(#\r "remove") #t #f
226 (lambda
(opt name arg result
)
227 (alist-cons
'remove arg result)))
228 (option '(#\p "profile") #t #f
229 (lambda
(opt name arg result
)
230 (alist-cons
'profile arg
231 (alist-delete 'profile result
))))
232 (option
'(#\n "dry-run") #f #f
233 (lambda (opt name arg result)
234 (alist-cons 'dry-run?
#t result)))
235 (option
'(#\b "bootstrap") #f #f
236 (lambda (opt name arg result)
237 (alist-cons 'bootstrap?
#t result)))))
244 (define
(guix-package . args
)
245 (define
(parse-options
)
246 ;; Return the alist of option values.
247 (args-fold args
%options
248 (lambda
(opt name arg result
)
249 (leave
(_
"~A: unrecognized option~%") name
))
251 (alist-cons
'argument arg result))
254 (define (show-what-to-build drv dry-run?)
255 ;; Show what will/would be built in realizing the derivations listed
257 (let* ((req (append-map (lambda (drv-path)
258 (let ((d (call-with-input-file drv-path
260 (derivation-prerequisites-to-build %store d)))
262 (req* (delete-duplicates
263 (append (remove (compose (cut valid-path? %store <>)
264 derivation-path->output-path)
266 (map derivation-input-path req)))))
268 (format (current-error-port)
269 (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
270 "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
273 (format (current-error-port)
274 (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
275 "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
277 (null? req*) req*))))
279 (define (find-package name)
280 ;; Find the package NAME; NAME may contain a version number and a
281 ;; sub-derivation name.
282 (define request name)
284 (let*-values (((name sub-drv)
285 (match (string-rindex name #\:)
286 (#f (values name "out"))
287 (colon (values (substring name (+ 1 colon))
288 (substring name colon)))))
290 (package-name->name+version name)))
291 (match (find-packages-by-name name version)
293 (list name version sub-drv p))
295 (format (current-error-port)
296 (_ "warning: ambiguous package specification `~a'~
%")
298 (format (current-error-port)
299 (_ "warning
: choosing ~s~
%")
301 (list name version sub-drv p))
303 (leave (_ "~a
: package not found~
%") request)))))
305 (setlocale LC_ALL "")
307 (setvbuf (current-output-port) _IOLBF)
308 (setvbuf (current-error-port) _IOLBF)
310 (let ((opts (parse-options)))
312 (parameterize ((%guile-for-build
313 (package-derivation %store
314 (if (assoc-ref opts 'bootstrap?)
315 (@@ (distro packages base)
318 (let* ((dry-run? (assoc-ref opts 'dry-run?))
319 (profile (assoc-ref opts 'profile))
320 (install (filter-map (match-lambda
321 (('install . (? store-path?))
323 (('install . package)
324 (find-package package))
327 (drv (filter-map (match-lambda
328 ((name version sub-drv
329 (? package? package))
330 (package-derivation %store package))
334 (filter-map (match-lambda
335 (('install . (? store-path? path))
336 `(,(store-path-package-name path)
340 (map (lambda (tuple drv)
342 ((name version sub-drv _)
344 (derivation-path->output-path
346 `(,name ,version ,sub-drv ,output-path)))))
348 (remove (filter-map (match-lambda
353 (packages (append install*
356 (profile-manifest profile))
359 (show-what-to-build drv dry-run?)
362 (and (build-derivations %store drv)
363 (let* ((prof-drv (profile-derivation %store packages))
364 (prof (derivation-path->output-path prof-drv))
365 (number (latest-profile-number profile))
366 (name (format #f "~a
/~a-~a-link
"
368 (basename profile) (+ 1 number))))
369 (and (build-derivations %store (list prof-drv))
372 (when (file-exists? profile)
373 (delete-file profile))
374 (symlink name profile)))))))))))
377 ;; eval: (put 'guard 'scheme-indent-function 1)