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 -I, --list-installed[=REGEXP]
206 list installed packages matching REGEXP"))
209 -h, --help display this help and exit"))
211 -V, --version display version information and exit"))
214 Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
217 ;; Specification of the command-line options.
218 (list (option '(#\h "help") #f #f
222 (option
'(#\V "version") #f #f
224 (show-version-and-exit "guix-package")))
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)
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 ""))
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))
259 (alist-cons 'argument arg result
))
262 (define
(show-what-to-build drv dry-run?
)
263 ;; Show what will
/would be built
in realizing the derivations listed
265 (let* ((req
(append-map
(lambda
(drv-path
)
266 (let ((d
(call-with-input-file drv-path
268 (derivation-prerequisites-to-build
%store d
)))
270 (req
* (delete-duplicates
271 (append
(remove
(compose
(cut valid-path?
%store
<>)
272 derivation-path-
>output-path
)
274 (map derivation-input-path req
)))))
276 (format
(current-error-port
)
277 (N_
"~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
278 "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
281 (format
(current-error-port
)
282 (N_
"~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
283 "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
285 (null? req
*) req
*))))
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
)
292 (let*-values (((name sub-drv
)
293 (match
(string-rindex name
#\:)
294 (#f (values name "out"))
295 (colon
(values
(substring name
0 colon
)
296 (substring name
(+ 1 colon
))))))
298 (package-name-
>name
+version name
)))
299 (match
(find-packages-by-name name version
)
301 (list name version sub-drv p
))
303 (format
(current-error-port
)
304 (_
"warning: ambiguous package specification `~a'~%")
306 (format
(current-error-port
)
307 (_
"warning: choosing ~s~%")
309 (list name version sub-drv p
))
311 (leave
(_
"~a: package not found~%") request
)))))
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?))
320 (('install . package
)
321 (find-package package
))
324 (drv
(filter-map
(match-lambda
325 ((name version sub-drv
326 (? package? package
))
327 (package-derivation
%store package
))
331 (filter-map
(match-lambda
332 (('install . (? store-path? path))
333 `(,(store-path-package-name path)
337 (map (lambda (tuple drv)
339 ((name version sub-drv _)
341 (derivation-path->output-path
343 `(,name ,version ,sub-drv ,output-path)))))
345 (remove (filter-map (match-lambda
350 (packages
(append
install*
353 (profile-manifest profile
))
356 (show-what-to-build drv 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"
365 (basename profile
) (+ 1 number
))))
366 (and
(build-derivations
%store
(list prof-drv
))
369 (when
(file-exists? profile
)
370 (delete-file profile
))
371 (symlink name profile
))))))))
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))))
391 (setlocale LC_ALL "")
393 (setvbuf (current-output-port) _IOLBF)
394 (setvbuf (current-error-port) _IOLBF)
396 (let ((opts (parse-options)))
398 (or (process-query opts)
399 (parameterize ((%guile-for-build
400 (package-derivation %store
401 (if (assoc-ref opts 'bootstrap?
)
402 (@@
(distro packages base
)
405 (process-actions opts
))))))
408 ;; eval: (put
'guard 'scheme-indent-function
1)