Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1ffa7090 | 2 | ;;; Copyright © 2012, 2013 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 LC |
30 | #:use-module (srfi srfi-1) |
31 | #:use-module (srfi srfi-26) | |
800cdeef LC |
32 | #:use-module (srfi srfi-39) |
33 | #:export (search-patch | |
ac5aa288 | 34 | search-bootstrap-binary |
800cdeef | 35 | %patch-directory |
0b3651bc | 36 | %bootstrap-binaries-path |
7d193ec3 | 37 | |
ba326ce4 | 38 | fold-packages |
7d193ec3 | 39 | |
dc5669cd | 40 | find-packages-by-name |
3f26bfc1 | 41 | find-best-packages-by-name |
7d193ec3 EB |
42 | find-newest-available-packages |
43 | ||
44 | package-direct-dependents | |
45 | package-transitive-dependents | |
4ea44419 AK |
46 | package-covering-dependents |
47 | ||
48 | check-package-freshness)) | |
6b1891b0 LC |
49 | |
50 | ;;; Commentary: | |
51 | ;;; | |
52 | ;;; General utilities for the software distribution---i.e., the modules under | |
59a43334 | 53 | ;;; (gnu packages ...). |
6b1891b0 LC |
54 | ;;; |
55 | ;;; Code: | |
56 | ||
0b3651bc LC |
57 | ;; By default, we store patches and bootstrap binaries alongside Guile |
58 | ;; modules. This is so that these extra files can be found without | |
59 | ;; requiring a special setup, such as a specific installation directory | |
60 | ;; and an extra environment variable. One advantage of this setup is | |
61 | ;; that everything just works in an auto-compilation setting. | |
a9f60c42 LC |
62 | |
63 | (define %patch-path | |
800cdeef | 64 | (make-parameter |
b211a661 | 65 | (map (cut string-append <> "/gnu/packages/patches") |
0b3651bc | 66 | %load-path))) |
800cdeef | 67 | |
a9f60c42 | 68 | (define %bootstrap-binaries-path |
ac5aa288 | 69 | (make-parameter |
1ffa7090 | 70 | (map (cut string-append <> "/gnu/packages/bootstrap") |
0b3651bc | 71 | %load-path))) |
ac5aa288 | 72 | |
800cdeef LC |
73 | (define (search-patch file-name) |
74 | "Search the patch FILE-NAME." | |
128663e4 | 75 | (search-path (%patch-path) file-name)) |
800cdeef | 76 | |
ac5aa288 LC |
77 | (define (search-bootstrap-binary file-name system) |
78 | "Search the bootstrap binary FILE-NAME for SYSTEM." | |
128663e4 LC |
79 | (search-path (%bootstrap-binaries-path) |
80 | (string-append system "/" file-name))) | |
ac5aa288 | 81 | |
6b1891b0 | 82 | (define %distro-module-directory |
1ffa7090 | 83 | ;; Absolute path of the (gnu packages ...) module root. |
59a43334 LC |
84 | (string-append (dirname (search-path %load-path "gnu/packages.scm")) |
85 | "/packages")) | |
6b1891b0 LC |
86 | |
87 | (define (package-files) | |
88 | "Return the list of files that implement distro modules." | |
89 | (define prefix-len | |
59a43334 LC |
90 | (string-length |
91 | (dirname (dirname (search-path %load-path "gnu/packages.scm"))))) | |
6b1891b0 LC |
92 | |
93 | (file-system-fold (const #t) ; enter? | |
94 | (lambda (path stat result) ; leaf | |
95 | (if (string-suffix? ".scm" path) | |
96 | (cons (substring path prefix-len) result) | |
97 | result)) | |
98 | (lambda (path stat result) ; down | |
99 | result) | |
100 | (lambda (path stat result) ; up | |
101 | result) | |
102 | (const #f) ; skip | |
103 | (lambda (path stat errno result) | |
98eb8cbe NK |
104 | (warning (_ "cannot access `~a': ~a~%") |
105 | path (strerror errno)) | |
6b1891b0 LC |
106 | result) |
107 | '() | |
108 | %distro-module-directory | |
109 | stat)) | |
110 | ||
111 | (define (package-modules) | |
112 | "Return the list of modules that provide packages for the distribution." | |
113 | (define not-slash | |
114 | (char-set-complement (char-set #\/))) | |
115 | ||
116 | (filter-map (lambda (path) | |
117 | (let ((name (map string->symbol | |
118 | (string-tokenize (string-drop-right path 4) | |
119 | not-slash)))) | |
120 | (false-if-exception (resolve-interface name)))) | |
121 | (package-files))) | |
122 | ||
ba326ce4 LC |
123 | (define (fold-packages proc init) |
124 | "Call (PROC PACKAGE RESULT) for each available package, using INIT as | |
c2868b1e MW |
125 | the initial value of RESULT. It is guaranteed to never traverse the |
126 | same package twice." | |
127 | (identity ; discard second return value | |
128 | (fold2 (lambda (module result seen) | |
129 | (fold2 (lambda (var result seen) | |
130 | (if (and (package? var) | |
131 | (not (vhash-assq var seen))) | |
132 | (values (proc var result) | |
133 | (vhash-consq var #t seen)) | |
134 | (values result seen))) | |
135 | result | |
136 | seen | |
137 | (module-map (lambda (sym var) | |
138 | (false-if-exception (variable-ref var))) | |
139 | module))) | |
140 | init | |
141 | vlist-null | |
142 | (package-modules)))) | |
ba326ce4 | 143 | |
6b1891b0 LC |
144 | (define* (find-packages-by-name name #:optional version) |
145 | "Return the list of packages with the given NAME. If VERSION is not #f, | |
146 | then only return packages whose version is equal to VERSION." | |
147 | (define right-package? | |
148 | (if version | |
149 | (lambda (p) | |
ba326ce4 | 150 | (and (string=? (package-name p) name) |
6b1891b0 LC |
151 | (string=? (package-version p) version))) |
152 | (lambda (p) | |
ba326ce4 LC |
153 | (string=? (package-name p) name)))) |
154 | ||
155 | (fold-packages (lambda (package result) | |
156 | (if (right-package? package) | |
157 | (cons package result) | |
158 | result)) | |
159 | '())) | |
dc5669cd | 160 | |
3f26bfc1 LC |
161 | (define find-newest-available-packages |
162 | (memoize | |
163 | (lambda () | |
164 | "Return a vhash keyed by package names, and with | |
dc5669cd MW |
165 | associated values of the form |
166 | ||
167 | (newest-version newest-package ...) | |
168 | ||
169 | where the preferred package is listed first." | |
170 | ||
3f26bfc1 LC |
171 | ;; FIXME: Currently, the preferred package is whichever one |
172 | ;; was found last by 'fold-packages'. Find a better solution. | |
173 | (fold-packages (lambda (p r) | |
174 | (let ((name (package-name p)) | |
175 | (version (package-version p))) | |
176 | (match (vhash-assoc name r) | |
177 | ((_ newest-so-far . pkgs) | |
178 | (case (version-compare version newest-so-far) | |
179 | ((>) (vhash-cons name `(,version ,p) r)) | |
180 | ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) | |
181 | ((<) r))) | |
182 | (#f (vhash-cons name `(,version ,p) r))))) | |
183 | vlist-null)))) | |
184 | ||
185 | (define (find-best-packages-by-name name version) | |
186 | "If version is #f, return the list of packages named NAME with the highest | |
187 | version numbers; otherwise, return the list of packages named NAME and at | |
188 | VERSION." | |
189 | (if version | |
190 | (find-packages-by-name name version) | |
191 | (match (vhash-assoc name (find-newest-available-packages)) | |
192 | ((_ version pkgs ...) pkgs) | |
193 | (#f '())))) | |
7d193ec3 EB |
194 | |
195 | \f | |
196 | (define* (vhash-refq vhash key #:optional (dflt #f)) | |
197 | "Look up KEY in the vhash VHASH, and return the value (if any) associated | |
198 | with it. If KEY is not found, return DFLT (or `#f' if no DFLT argument is | |
199 | supplied). Uses `eq?' for equality testing." | |
200 | (or (and=> (vhash-assq key vhash) cdr) | |
201 | dflt)) | |
202 | ||
203 | (define package-dependencies | |
204 | (memoize | |
205 | (lambda () | |
206 | "Return a vhash keyed by package, and with associated values that are a | |
207 | list of packages that depend on that package." | |
208 | (fold-packages | |
209 | (lambda (package dag) | |
210 | (fold | |
211 | (lambda (in d) | |
212 | ;; Insert a graph edge from each of package's inputs to package. | |
213 | (vhash-consq in | |
214 | (cons package (vhash-refq d in '())) | |
215 | (vhash-delq in d))) | |
216 | dag | |
217 | (match (package-direct-inputs package) | |
218 | (((labels packages . _) ...) | |
219 | packages) ))) | |
220 | vlist-null)))) | |
221 | ||
222 | (define (package-direct-dependents packages) | |
223 | "Return a list of packages from the distribution that directly depend on the | |
224 | packages in PACKAGES." | |
225 | (delete-duplicates | |
226 | (concatenate | |
227 | (map (lambda (p) | |
228 | (vhash-refq (package-dependencies) p '())) | |
229 | packages)))) | |
230 | ||
231 | (define (package-transitive-dependents packages) | |
232 | "Return the transitive dependent packages of the distribution packages in | |
233 | PACKAGES---i.e. the dependents of those packages, plus their dependents, | |
234 | recursively." | |
235 | (let ((dependency-dag (package-dependencies))) | |
236 | (fold-tree | |
237 | cons '() | |
238 | (lambda (node) (vhash-refq dependency-dag node)) | |
239 | ;; Start with the dependents to avoid including PACKAGES in the result. | |
240 | (package-direct-dependents packages)))) | |
241 | ||
242 | (define (package-covering-dependents packages) | |
243 | "Return a minimal list of packages from the distribution whose dependencies | |
244 | include all of PACKAGES and all packages that depend on PACKAGES." | |
245 | (let ((dependency-dag (package-dependencies))) | |
246 | (fold-tree-leaves | |
247 | cons '() | |
248 | (lambda (node) (vhash-refq dependency-dag node)) | |
249 | ;; Start with the dependents to avoid including PACKAGES in the result. | |
250 | (package-direct-dependents packages)))) | |
4ea44419 AK |
251 | |
252 | \f | |
253 | (define %sigint-prompt | |
254 | ;; The prompt to jump to upon SIGINT. | |
255 | (make-prompt-tag "interruptible")) | |
256 | ||
257 | (define (call-with-sigint-handler thunk handler) | |
258 | "Call THUNK and return its value. Upon SIGINT, call HANDLER with the signal | |
259 | number in the context of the continuation of the call to this function, and | |
260 | return its return value." | |
261 | (call-with-prompt %sigint-prompt | |
262 | (lambda () | |
263 | (sigaction SIGINT | |
264 | (lambda (signum) | |
265 | (sigaction SIGINT SIG_DFL) | |
266 | (abort-to-prompt %sigint-prompt signum))) | |
267 | (dynamic-wind | |
268 | (const #t) | |
269 | thunk | |
270 | (cut sigaction SIGINT SIG_DFL))) | |
271 | (lambda (k signum) | |
272 | (handler signum)))) | |
273 | ||
274 | (define-syntax-rule (waiting exp fmt rest ...) | |
275 | "Display the given message while EXP is being evaluated." | |
276 | (let* ((message (format #f fmt rest ...)) | |
277 | (blank (make-string (string-length message) #\space))) | |
278 | (display message (current-error-port)) | |
279 | (force-output (current-error-port)) | |
280 | (call-with-sigint-handler | |
281 | (lambda () | |
282 | (dynamic-wind | |
283 | (const #f) | |
284 | (lambda () exp) | |
285 | (lambda () | |
286 | ;; Clear the line. | |
287 | (display #\cr (current-error-port)) | |
288 | (display blank (current-error-port)) | |
289 | (display #\cr (current-error-port)) | |
290 | (force-output (current-error-port))))) | |
291 | (lambda (signum) | |
292 | (format (current-error-port) " interrupted by signal ~a~%" SIGINT) | |
293 | #f)))) | |
294 | ||
295 | (define ftp-open* | |
296 | ;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new | |
297 | ;; FTP connection for each package, esp. since most of them are to the same | |
298 | ;; server. This has a noticeable impact when doing "guix upgrade -u". | |
299 | (memoize ftp-open)) | |
300 | ||
301 | (define (check-package-freshness package) | |
302 | "Check whether PACKAGE has a newer version available upstream, and report | |
303 | it." | |
304 | ;; TODO: Automatically inject the upstream version when desired. | |
305 | ||
306 | (catch #t | |
307 | (lambda () | |
308 | (when (false-if-exception (gnu-package? package)) | |
309 | (let ((name (package-name package)) | |
310 | (full-name (package-full-name package))) | |
311 | (match (waiting (latest-release name | |
312 | #:ftp-open ftp-open* | |
313 | #:ftp-close (const #f)) | |
314 | (_ "looking for the latest release of GNU ~a...") name) | |
315 | ((latest-version . _) | |
316 | (when (version>? latest-version full-name) | |
317 | (format (current-error-port) | |
318 | (_ "~a: note: using ~a \ | |
319 | but ~a is available upstream~%") | |
320 | (location->string (package-location package)) | |
321 | full-name latest-version))) | |
322 | (_ #t))))) | |
323 | (lambda (key . args) | |
324 | ;; Silently ignore networking errors rather than preventing | |
325 | ;; installation. | |
326 | (case key | |
327 | ((getaddrinfo-error ftp-error) #f) | |
328 | (else (apply throw key args)))))) |