Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
84836a57 | 2 | ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> |
c2868b1e | 3 | ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> |
7d193ec3 | 4 | ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> |
6b1891b0 | 5 | ;;; |
233e7676 | 6 | ;;; This file is part of GNU Guix. |
6b1891b0 | 7 | ;;; |
233e7676 | 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
6b1891b0 LC |
9 | ;;; under the terms of the GNU General Public License as published by |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
233e7676 | 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
6b1891b0 LC |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
233e7676 | 19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
6b1891b0 | 20 | |
59a43334 | 21 | (define-module (gnu packages) |
6b1891b0 | 22 | #:use-module (guix packages) |
98eb8cbe | 23 | #:use-module (guix ui) |
800cdeef | 24 | #:use-module (guix utils) |
4ea44419 AK |
25 | #:use-module ((guix ftp-client) #:select (ftp-open)) |
26 | #:use-module (guix gnu-maintenance) | |
6b1891b0 | 27 | #:use-module (ice-9 ftw) |
c2868b1e | 28 | #:use-module (ice-9 vlist) |
dc5669cd | 29 | #:use-module (ice-9 match) |
6b1891b0 | 30 | #:use-module (srfi srfi-1) |
5e3b388b | 31 | #:use-module (srfi srfi-11) |
6b1891b0 | 32 | #:use-module (srfi srfi-26) |
800cdeef LC |
33 | #:use-module (srfi srfi-39) |
34 | #:export (search-patch | |
ac5aa288 | 35 | search-bootstrap-binary |
800cdeef | 36 | %patch-directory |
0b3651bc | 37 | %bootstrap-binaries-path |
c107b541 | 38 | %package-module-path |
7d193ec3 | 39 | |
ba326ce4 | 40 | fold-packages |
7d193ec3 | 41 | |
dc5669cd | 42 | find-packages-by-name |
3f26bfc1 | 43 | find-best-packages-by-name |
7d193ec3 EB |
44 | find-newest-available-packages |
45 | ||
46 | package-direct-dependents | |
47 | package-transitive-dependents | |
4ea44419 AK |
48 | package-covering-dependents |
49 | ||
5e3b388b CR |
50 | check-package-freshness |
51 | ||
52 | specification->package)) | |
6b1891b0 LC |
53 | |
54 | ;;; Commentary: | |
55 | ;;; | |
56 | ;;; General utilities for the software distribution---i.e., the modules under | |
59a43334 | 57 | ;;; (gnu packages ...). |
6b1891b0 LC |
58 | ;;; |
59 | ;;; Code: | |
60 | ||
0b3651bc LC |
61 | ;; By default, we store patches and bootstrap binaries alongside Guile |
62 | ;; modules. This is so that these extra files can be found without | |
63 | ;; requiring a special setup, such as a specific installation directory | |
64 | ;; and an extra environment variable. One advantage of this setup is | |
65 | ;; that everything just works in an auto-compilation setting. | |
a9f60c42 LC |
66 | |
67 | (define %patch-path | |
800cdeef | 68 | (make-parameter |
b211a661 | 69 | (map (cut string-append <> "/gnu/packages/patches") |
0b3651bc | 70 | %load-path))) |
800cdeef | 71 | |
a9f60c42 | 72 | (define %bootstrap-binaries-path |
ac5aa288 | 73 | (make-parameter |
1ffa7090 | 74 | (map (cut string-append <> "/gnu/packages/bootstrap") |
0b3651bc | 75 | %load-path))) |
ac5aa288 | 76 | |
800cdeef LC |
77 | (define (search-patch file-name) |
78 | "Search the patch FILE-NAME." | |
128663e4 | 79 | (search-path (%patch-path) file-name)) |
800cdeef | 80 | |
ac5aa288 LC |
81 | (define (search-bootstrap-binary file-name system) |
82 | "Search the bootstrap binary FILE-NAME for SYSTEM." | |
128663e4 LC |
83 | (search-path (%bootstrap-binaries-path) |
84 | (string-append system "/" file-name))) | |
ac5aa288 | 85 | |
84836a57 LC |
86 | (define %distro-root-directory |
87 | ;; Absolute file name of the module hierarchy. | |
88 | (dirname (search-path %load-path "guix.scm"))) | |
6b1891b0 | 89 | |
c107b541 LC |
90 | (define %package-module-path |
91 | ;; Search path for package modules. Each item must be either a directory | |
92 | ;; name or a pair whose car is a directory and whose cdr is a sub-directory | |
93 | ;; to narrow the search. | |
8689901f LC |
94 | (let* ((not-colon (char-set-complement (char-set #\:))) |
95 | (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "") | |
96 | not-colon))) | |
97 | ;; Automatically add items from $GUIX_PACKAGE_PATH to Guile's search path. | |
98 | (for-each (lambda (directory) | |
99 | (set! %load-path (cons directory %load-path)) | |
100 | (set! %load-compiled-path | |
101 | (cons directory %load-compiled-path))) | |
102 | environment) | |
103 | ||
104 | (make-parameter | |
105 | (append environment `((,%distro-root-directory . "gnu/packages")))))) | |
c107b541 | 106 | |
84836a57 LC |
107 | (define* (scheme-files directory) |
108 | "Return the list of Scheme files found under DIRECTORY." | |
6b1891b0 LC |
109 | (file-system-fold (const #t) ; enter? |
110 | (lambda (path stat result) ; leaf | |
111 | (if (string-suffix? ".scm" path) | |
84836a57 | 112 | (cons path result) |
6b1891b0 LC |
113 | result)) |
114 | (lambda (path stat result) ; down | |
115 | result) | |
116 | (lambda (path stat result) ; up | |
117 | result) | |
118 | (const #f) ; skip | |
119 | (lambda (path stat errno result) | |
98eb8cbe NK |
120 | (warning (_ "cannot access `~a': ~a~%") |
121 | path (strerror errno)) | |
6b1891b0 LC |
122 | result) |
123 | '() | |
84836a57 | 124 | directory |
6b1891b0 LC |
125 | stat)) |
126 | ||
c107b541 LC |
127 | (define file-name->module-name |
128 | (let ((not-slash (char-set-complement (char-set #\/)))) | |
129 | (lambda (file) | |
130 | "Return the module name (a list of symbols) corresponding to FILE." | |
131 | (map string->symbol | |
132 | (string-tokenize (string-drop-right file 4) not-slash))))) | |
84836a57 LC |
133 | |
134 | (define* (package-modules directory #:optional sub-directory) | |
135 | "Return the list of modules that provide packages for the distribution. | |
136 | Optionally, narrow the search to SUB-DIRECTORY." | |
137 | (define prefix-len | |
138 | (string-length directory)) | |
139 | ||
140 | (filter-map (lambda (file) | |
141 | (let ((file (substring file prefix-len))) | |
142 | (false-if-exception | |
143 | (resolve-interface (file-name->module-name file))))) | |
144 | (scheme-files (if sub-directory | |
145 | (string-append directory "/" sub-directory) | |
146 | directory)))) | |
6b1891b0 | 147 | |
c107b541 LC |
148 | (define* (all-package-modules #:optional (path (%package-module-path))) |
149 | "Return the list of package modules found in PATH, a list of directories to | |
150 | search." | |
151 | (fold-right (lambda (spec result) | |
152 | (match spec | |
153 | ((? string? directory) | |
154 | (append (package-modules directory) result)) | |
155 | ((directory . sub-directory) | |
156 | (append (package-modules directory sub-directory) | |
157 | result)))) | |
158 | '() | |
159 | path)) | |
160 | ||
ba326ce4 LC |
161 | (define (fold-packages proc init) |
162 | "Call (PROC PACKAGE RESULT) for each available package, using INIT as | |
c2868b1e MW |
163 | the initial value of RESULT. It is guaranteed to never traverse the |
164 | same package twice." | |
165 | (identity ; discard second return value | |
166 | (fold2 (lambda (module result seen) | |
167 | (fold2 (lambda (var result seen) | |
168 | (if (and (package? var) | |
169 | (not (vhash-assq var seen))) | |
170 | (values (proc var result) | |
171 | (vhash-consq var #t seen)) | |
172 | (values result seen))) | |
173 | result | |
174 | seen | |
175 | (module-map (lambda (sym var) | |
176 | (false-if-exception (variable-ref var))) | |
177 | module))) | |
178 | init | |
179 | vlist-null | |
c107b541 | 180 | (all-package-modules)))) |
ba326ce4 | 181 | |
9ffc1c00 LC |
182 | (define find-packages-by-name |
183 | (let ((packages (delay | |
184 | (fold-packages (lambda (p r) | |
185 | (vhash-cons (package-name p) p r)) | |
186 | vlist-null)))) | |
187 | (lambda* (name #:optional version) | |
188 | "Return the list of packages with the given NAME. If VERSION is not #f, | |
6b1891b0 | 189 | then only return packages whose version is equal to VERSION." |
9ffc1c00 LC |
190 | (let ((matching (vhash-fold* cons '() name (force packages)))) |
191 | (if version | |
192 | (filter (lambda (package) | |
193 | (string=? (package-version package) version)) | |
194 | matching) | |
195 | matching))))) | |
dc5669cd | 196 | |
3f26bfc1 LC |
197 | (define find-newest-available-packages |
198 | (memoize | |
199 | (lambda () | |
200 | "Return a vhash keyed by package names, and with | |
dc5669cd MW |
201 | associated values of the form |
202 | ||
203 | (newest-version newest-package ...) | |
204 | ||
205 | where the preferred package is listed first." | |
206 | ||
3f26bfc1 LC |
207 | ;; FIXME: Currently, the preferred package is whichever one |
208 | ;; was found last by 'fold-packages'. Find a better solution. | |
209 | (fold-packages (lambda (p r) | |
210 | (let ((name (package-name p)) | |
211 | (version (package-version p))) | |
212 | (match (vhash-assoc name r) | |
213 | ((_ newest-so-far . pkgs) | |
214 | (case (version-compare version newest-so-far) | |
215 | ((>) (vhash-cons name `(,version ,p) r)) | |
216 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) | |
217 | ((<) r))) | |
218 | (#f (vhash-cons name `(,version ,p) r))))) | |
219 | vlist-null)))) | |
220 | ||
221 | (define (find-best-packages-by-name name version) | |
222 | "If version is #f, return the list of packages named NAME with the highest | |
223 | version numbers; otherwise, return the list of packages named NAME and at | |
224 | VERSION." | |
225 | (if version | |
226 | (find-packages-by-name name version) | |
227 | (match (vhash-assoc name (find-newest-available-packages)) | |
228 | ((_ version pkgs ...) pkgs) | |
229 | (#f '())))) | |
7d193ec3 EB |
230 | |
231 | \f | |
232 | (define* (vhash-refq vhash key #:optional (dflt #f)) | |
233 | "Look up KEY in the vhash VHASH, and return the value (if any) associated | |
234 | with it. If KEY is not found, return DFLT (or `#f' if no DFLT argument is | |
235 | supplied). Uses `eq?' for equality testing." | |
236 | (or (and=> (vhash-assq key vhash) cdr) | |
237 | dflt)) | |
238 | ||
239 | (define package-dependencies | |
240 | (memoize | |
241 | (lambda () | |
242 | "Return a vhash keyed by package, and with associated values that are a | |
243 | list of packages that depend on that package." | |
244 | (fold-packages | |
245 | (lambda (package dag) | |
246 | (fold | |
247 | (lambda (in d) | |
248 | ;; Insert a graph edge from each of package's inputs to package. | |
249 | (vhash-consq in | |
250 | (cons package (vhash-refq d in '())) | |
251 | (vhash-delq in d))) | |
252 | dag | |
253 | (match (package-direct-inputs package) | |
254 | (((labels packages . _) ...) | |
255 | packages) ))) | |
256 | vlist-null)))) | |
257 | ||
258 | (define (package-direct-dependents packages) | |
259 | "Return a list of packages from the distribution that directly depend on the | |
260 | packages in PACKAGES." | |
261 | (delete-duplicates | |
262 | (concatenate | |
263 | (map (lambda (p) | |
264 | (vhash-refq (package-dependencies) p '())) | |
265 | packages)))) | |
266 | ||
267 | (define (package-transitive-dependents packages) | |
268 | "Return the transitive dependent packages of the distribution packages in | |
269 | PACKAGES---i.e. the dependents of those packages, plus their dependents, | |
270 | recursively." | |
271 | (let ((dependency-dag (package-dependencies))) | |
272 | (fold-tree | |
273 | cons '() | |
274 | (lambda (node) (vhash-refq dependency-dag node)) | |
275 | ;; Start with the dependents to avoid including PACKAGES in the result. | |
276 | (package-direct-dependents packages)))) | |
277 | ||
278 | (define (package-covering-dependents packages) | |
279 | "Return a minimal list of packages from the distribution whose dependencies | |
280 | include all of PACKAGES and all packages that depend on PACKAGES." | |
281 | (let ((dependency-dag (package-dependencies))) | |
282 | (fold-tree-leaves | |
283 | cons '() | |
284 | (lambda (node) (vhash-refq dependency-dag node)) | |
285 | ;; Start with the dependents to avoid including PACKAGES in the result. | |
286 | (package-direct-dependents packages)))) | |
4ea44419 AK |
287 | |
288 | \f | |
289 | (define %sigint-prompt | |
290 | ;; The prompt to jump to upon SIGINT. | |
291 | (make-prompt-tag "interruptible")) | |
292 | ||
293 | (define (call-with-sigint-handler thunk handler) | |
294 | "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal | |
295 | number in the context of the continuation of the call to this function, and | |
296 | return its return value." | |
297 | (call-with-prompt %sigint-prompt | |
298 | (lambda () | |
299 | (sigaction SIGINT | |
300 | (lambda (signum) | |
301 | (sigaction SIGINT SIG_DFL) | |
302 | (abort-to-prompt %sigint-prompt signum))) | |
303 | (dynamic-wind | |
304 | (const #t) | |
305 | thunk | |
306 | (cut sigaction SIGINT SIG_DFL))) | |
307 | (lambda (k signum) | |
308 | (handler signum)))) | |
309 | ||
310 | (define-syntax-rule (waiting exp fmt rest ...) | |
311 | "Display the given message while EXP is being evaluated." | |
312 | (let* ((message (format #f fmt rest ...)) | |
313 | (blank (make-string (string-length message) #\space))) | |
314 | (display message (current-error-port)) | |
315 | (force-output (current-error-port)) | |
316 | (call-with-sigint-handler | |
317 | (lambda () | |
318 | (dynamic-wind | |
319 | (const #f) | |
320 | (lambda () exp) | |
321 | (lambda () | |
322 | ;; Clear the line. | |
323 | (display #\cr (current-error-port)) | |
324 | (display blank (current-error-port)) | |
325 | (display #\cr (current-error-port)) | |
326 | (force-output (current-error-port))))) | |
327 | (lambda (signum) | |
328 | (format (current-error-port) " interrupted by signal ~a~%" SIGINT) | |
329 | #f)))) | |
330 | ||
331 | (define ftp-open* | |
332 | ;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new | |
333 | ;; FTP connection for each package, esp. since most of them are to the same | |
334 | ;; server. This has a noticeable impact when doing "guix upgrade -u". | |
335 | (memoize ftp-open)) | |
336 | ||
337 | (define (check-package-freshness package) | |
338 | "Check whether PACKAGE has a newer version available upstream, and report | |
339 | it." | |
340 | ;; TODO: Automatically inject the upstream version when desired. | |
341 | ||
342 | (catch #t | |
343 | (lambda () | |
344 | (when (false-if-exception (gnu-package? package)) | |
345 | (let ((name (package-name package)) | |
346 | (full-name (package-full-name package))) | |
347 | (match (waiting (latest-release name | |
348 | #:ftp-open ftp-open* | |
349 | #:ftp-close (const #f)) | |
350 | (_ "looking for the latest release of GNU ~a...") name) | |
501d7647 LC |
351 | ((? gnu-release? release) |
352 | (let ((latest-version | |
353 | (string-append (gnu-release-package release) "-" | |
354 | (gnu-release-version release)))) | |
355 | (when (version>? latest-version full-name) | |
356 | (format (current-error-port) | |
357 | (_ "~a: note: using ~a \ | |
4ea44419 | 358 | but ~a is available upstream~%") |
501d7647 LC |
359 | (location->string (package-location package)) |
360 | full-name latest-version)))) | |
4ea44419 AK |
361 | (_ #t))))) |
362 | (lambda (key . args) | |
363 | ;; Silently ignore networking errors rather than preventing | |
364 | ;; installation. | |
365 | (case key | |
366 | ((getaddrinfo-error ftp-error) #f) | |
367 | (else (apply throw key args)))))) | |
5e3b388b CR |
368 | |
369 | (define (specification->package spec) | |
370 | "Return a package matching SPEC. SPEC may be a package name, or a package | |
371 | name followed by a hyphen and a version number. If the version number is not | |
372 | present, return the preferred newest version." | |
373 | (let-values (((name version) | |
374 | (package-name->name+version spec))) | |
375 | (match (find-best-packages-by-name name version) | |
376 | ((p) ; one match | |
377 | p) | |
378 | ((p x ...) ; several matches | |
379 | (warning (_ "ambiguous package specification `~a'~%") spec) | |
380 | (warning (_ "choosing ~a from ~a~%") | |
381 | (package-full-name p) | |
382 | (location->string (package-location p))) | |
383 | p) | |
384 | (_ ; no matches | |
385 | (if version | |
386 | (leave (_ "~A: package not found for version ~a~%") | |
387 | name version) | |
388 | (leave (_ "~A: unknown package~%") name)))))) |