1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
4 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
5 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
6 ;;; Copyright © 2017, 2019 Efraim Flashner <efraim@flashner.co.il>
7 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
9 ;;; This file is part of GNU Guix.
11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
12 ;;; under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation; either version 3 of the License, or (at
14 ;;; your option) any later version.
16 ;;; GNU Guix is distributed in the hope that it will be useful, but
17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU General Public License for more details.
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
24 (define-module (guix packages)
25 #:use-module (guix utils)
26 #:use-module (guix records)
27 #:use-module (guix store)
28 #:use-module (guix monads)
29 #:use-module (guix gexp)
30 #:use-module (guix base32)
31 #:use-module (guix grafts)
32 #:use-module (guix derivations)
33 #:use-module (guix memoization)
34 #:use-module (guix build-system)
35 #:use-module (guix search-paths)
36 #:use-module (guix sets)
37 #:use-module (ice-9 match)
38 #:use-module (ice-9 vlist)
39 #:use-module (ice-9 regex)
40 #:use-module (srfi srfi-1)
41 #:use-module (srfi srfi-9 gnu)
42 #:use-module (srfi srfi-11)
43 #:use-module (srfi srfi-26)
44 #:use-module (srfi srfi-34)
45 #:use-module (srfi srfi-35)
46 #:use-module (web uri)
47 #:re-export (%current-system
48 %current-target-system
49 search-path-specification) ;for convenience
57 origin-actual-file-name
78 package-propagated-inputs
80 package-native-search-paths
87 package-supported-systems
94 package-field-location
96 package-direct-sources
97 package-transitive-sources
99 package-transitive-inputs
100 package-transitive-target-inputs
101 package-transitive-native-inputs
102 package-transitive-propagated-inputs
103 package-transitive-native-search-paths
104 package-transitive-supported-systems
106 package-input-rewriting
107 package-input-rewriting/spec
108 package-source-derivation
110 package-cross-derivation
113 package-patched-vulnerabilities
115 package-with-extra-patches
118 transitive-input-references
122 %hydra-supported-systems
127 package-error-package
130 package-error-invalid-input
131 &package-cross-build-system-error
132 package-cross-build-system-error?
137 bag-transitive-inputs
138 bag-transitive-host-inputs
139 bag-transitive-build-inputs
140 bag-transitive-target-inputs
144 default-guile-derivation
148 package->cross-derivation
153 ;;; This module provides a high-level mechanism to define packages in a
154 ;;; Guix-based distribution.
158 ;; The source of a package, such as a tarball URL and fetcher---called
159 ;; "origin" to avoid name clash with `package-source', `source', etc.
160 (define-record-type* <origin>
164 (uri origin-uri) ; string
165 (method origin-method) ; procedure
166 (sha256 origin-sha256) ; bytevector
167 (file-name origin-file-name (default #f)) ; optional file name
169 ;; Patches are delayed so that the 'search-patch' calls are made lazily,
170 ;; which reduces I/O on startup and allows patch-not-found errors to be
171 ;; gracefully handled at run time.
172 (patches origin-patches ; list of file names
173 (default '()) (delayed))
175 (snippet origin-snippet (default #f)) ; sexp or #f
176 (patch-flags origin-patch-flags ; list of strings
179 ;; Patching requires Guile, GNU Patch, and a few more. These two fields are
180 ;; used to specify these dependencies when needed.
181 (patch-inputs origin-patch-inputs ; input list or #f
183 (modules origin-modules ; list of module names
186 (patch-guile origin-patch-guile ; package or #f
189 (define (print-origin origin port)
190 "Write a concise representation of ORIGIN to PORT."
192 (($ <origin> uri method sha256 file-name patches)
193 (simple-format port "#<origin ~s ~a ~s ~a>"
194 uri (bytevector->base32-string sha256)
196 (number->string (object-address origin) 16)))))
198 (set-record-type-printer! <origin> print-origin)
200 (define-syntax base32
202 "Return the bytevector corresponding to the given Nix-base32
206 (string? (syntax->datum #'str))
207 ;; A literal string: do the conversion at expansion time.
208 (with-syntax ((bv (nix-base32-string->bytevector
209 (syntax->datum #'str))))
212 #'(nix-base32-string->bytevector str)))))
214 (define (origin-actual-file-name origin)
215 "Return the file name of ORIGIN, either its 'file-name' field or the file
217 (define (uri->file-name uri)
218 ;; Return the 'base name' of URI or URI itself, where URI is a string.
219 (let ((path (and=> (string->uri uri) uri-path)))
224 (or (origin-file-name origin)
225 (match (origin-uri origin)
227 (uri->file-name head))
229 (uri->file-name uri))
231 ;; git, svn, cvs, etc. reference
234 (define %supported-systems
235 ;; This is the list of system types that are supported. By default, we
236 ;; expect all packages to build successfully here.
237 '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))
239 (define %hurd-systems
240 ;; The GNU/Hurd systems for which support is being developed.
241 '("i586-gnu" "i686-gnu"))
243 (define %hydra-supported-systems
244 ;; This is the list of system types for which build machines are available.
246 ;; XXX: MIPS is unavailable in CI:
247 ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
248 (fold delete %supported-systems '("mips64el-linux")))
252 (define-record-type* <package>
256 (name package-name) ; string
257 (version package-version) ; string
258 (source package-source) ; <origin> instance
259 (build-system package-build-system) ; build system
260 (arguments package-arguments ; arguments for the build method
261 (default '()) (thunked))
263 (inputs package-inputs ; input packages or derivations
264 (default '()) (thunked))
265 (propagated-inputs package-propagated-inputs ; same, but propagated
266 (default '()) (thunked))
267 (native-inputs package-native-inputs ; native input packages/derivations
268 (default '()) (thunked))
270 (outputs package-outputs ; list of strings
274 ; <search-path-specification>,
275 ; for native and cross
277 (native-search-paths package-native-search-paths (default '()))
278 (search-paths package-search-paths (default '()))
280 ;; The 'replacement' field is marked as "innate" because it never makes
281 ;; sense to inherit a replacement as is. See the 'package/inherit' macro.
282 (replacement package-replacement ; package | #f
283 (default #f) (thunked) (innate))
285 (synopsis package-synopsis) ; one-line description
286 (description package-description) ; one or two paragraphs
287 (license package-license)
288 (home-page package-home-page)
289 (supported-systems package-supported-systems ; list of strings
290 (default %supported-systems))
292 (properties package-properties (default '())) ; alist for anything else
294 (location package-location
295 (default (and=> (current-source-location)
296 source-properties->location))
299 (set-record-type-printer! <package>
300 (lambda (package port)
301 (let ((loc (package-location package))
302 (format simple-format))
303 (format port "#<package ~a@~a ~a~a>"
304 (package-name package)
305 (package-version package)
311 (number->string (object-address
315 (define (package-upstream-name package)
316 "Return the upstream name of PACKAGE, which could be different from the name
318 (or (assq-ref (package-properties package) 'upstream-name)
319 (package-name package)))
321 (define (hidden-package p)
322 "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
323 user interfaces, ignores."
326 (properties `((hidden? . #t)
327 ,@(package-properties p)))))
329 (define (hidden-package? p)
330 "Return true if P is \"hidden\"--i.e., must not be visible to user
332 (assoc-ref (package-properties p) 'hidden?))
334 (define (package-superseded p)
335 "Return the package the supersedes P, or #f if P is still current."
336 (assoc-ref (package-properties p) 'superseded))
338 (define (deprecated-package old-name p)
339 "Return a package called OLD-NAME and marked as superseded by P, a package
344 (properties `((superseded . ,p)))))
346 (define (package-field-location package field)
347 "Return the source code location of the definition of FIELD for PACKAGE, or
348 #f if it could not be determined."
349 (define (goto port line column)
350 (unless (and (= (port-column port) (- column 1))
351 (= (port-line port) (- line 1)))
352 (unless (eof-object? (read-char port))
353 (goto port line column))))
355 (match (package-location package)
356 (($ <location> file line column)
359 ;; In general we want to keep relative file names for modules.
360 (call-with-input-file (search-path %load-path file)
362 (goto port line column)
364 (('package inits ...)
365 (let ((field (assoc field inits)))
368 (let ((loc (and=> (source-properties value)
369 source-properties->location)))
371 ;; Preserve the original file name, which may be a
372 ;; relative file name.
373 (set-field loc (location-file) file))))
385 (define-condition-type &package-error &error
387 (package package-error-package))
389 (define-condition-type &package-input-error &package-error
391 (input package-error-invalid-input))
393 (define-condition-type &package-cross-build-system-error &package-error
394 package-cross-build-system-error?)
396 (define* (package-full-name package #:optional (delimiter "@"))
397 "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying
398 DELIMITER (a string), you can customize what will appear between the name and
399 the version. By default, DELIMITER is \"@\"."
400 (string-append (package-name package) delimiter (package-version package)))
402 (define (patch-file-name patch)
403 "Return the basename of PATCH's file name, or #f if the file name could not
409 (and=> (origin-actual-file-name patch) basename))))
411 (define %vulnerability-regexp
412 ;; Regexp matching a CVE identifier in patch file names.
413 (make-regexp "CVE-[0-9]{4}-[0-9]+"))
415 (define (package-patched-vulnerabilities package)
416 "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
417 identifiers. The result is inferred from the file names of patches."
418 (define (patch-vulnerabilities patch)
419 (map (cut match:substring <> 0)
420 (list-matches %vulnerability-regexp patch)))
422 (let ((patches (filter-map patch-file-name
423 (or (and=> (package-source package)
426 (append-map patch-vulnerabilities patches)))
428 (define (%standard-patch-inputs)
429 (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
431 (ref (lambda (module var)
433 (module-ref (resolve-interface module) var)))))
434 `(("tar" ,(ref '(gnu packages base) 'tar))
435 ("xz" ,(ref '(gnu packages compression) 'xz))
436 ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
437 ("gzip" ,(ref '(gnu packages compression) 'gzip))
438 ("lzip" ,(ref '(gnu packages compression) 'lzip))
439 ("unzip" ,(ref '(gnu packages compression) 'unzip))
440 ("patch" ,(ref '(gnu packages base) 'patch))
441 ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
443 (define (default-guile)
444 "Return the default Guile package used to run the build code of
446 (let ((distro (resolve-interface '(gnu packages commencement))))
447 (module-ref distro 'guile-final)))
449 (define (guile-for-grafts)
450 "Return the Guile package used to build grafting derivations."
451 ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
452 ;; grafting packages.
453 (let ((distro (resolve-interface '(gnu packages guile))))
454 (module-ref distro 'guile-2.0)))
456 (define* (default-guile-derivation #:optional (system (%current-system)))
457 "Return the derivation for SYSTEM of the default Guile package used to run
458 the build code of derivation."
459 (package->derivation (default-guile) system
462 (define* (patch-and-repack source patches
468 (guile-for-build (%guile-for-build))
469 (system (%current-system)))
470 "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
471 repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
472 it must be an s-expression that will run from within the directory where
473 SOURCE was unpacked, after all of PATCHES have been applied. MODULES
474 specifies modules in scope when evaluating SNIPPET."
475 (define source-file-name
476 ;; SOURCE is usually a derivation, but it could be a store file.
477 (if (derivation? source)
478 (derivation->output-path source)
482 ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
483 ;; so deal with that.
484 (let ((inputs (or inputs (%standard-patch-inputs))))
486 (match (assoc-ref inputs name)
490 (define decompression-type
491 (cond ((string-suffix? "gz" source-file-name) "gzip")
492 ((string-suffix? "Z" source-file-name) "gzip")
493 ((string-suffix? "bz2" source-file-name) "bzip2")
494 ((string-suffix? "lz" source-file-name) "lzip")
495 ((string-suffix? "zip" source-file-name) "unzip")
498 (define original-file-name
499 ;; Remove the store prefix plus the slash, hash, and hyphen.
500 (let* ((sans (string-drop source-file-name
501 (+ (string-length (%store-prefix)) 1)))
502 (dash (string-index sans #\-)))
503 (string-drop sans (+ 1 dash))))
505 (define (numeric-extension? file-name)
506 ;; Return true if FILE-NAME ends with digits.
507 (and=> (file-extension file-name)
508 (cut string-every char-set:hex-digit <>)))
510 (define (checkout? directory)
511 ;; Return true if DIRECTORY is a checkout (git, svn, etc).
512 (string-suffix? "-checkout" directory))
514 (define (tarxz-name file-name)
515 ;; Return a '.tar.xz' file name based on FILE-NAME.
516 (let ((base (cond ((numeric-extension? file-name)
518 ((checkout? file-name)
519 (string-drop-right file-name 9))
520 (else (file-sans-extension file-name)))))
522 (if (equal? (file-extension base) "tar")
526 (define instantiate-patch
528 ((? string? patch) ;deprecated
529 (interned-file patch #:recursive? #t))
530 ((? struct? patch) ;origin, local-file, etc.
531 (lower-object patch system))))
533 (mlet %store-monad ((tar -> (lookup-input "tar"))
534 (xz -> (lookup-input "xz"))
535 (patch -> (lookup-input "patch"))
536 (locales -> (lookup-input "locales"))
537 (decomp -> (lookup-input decompression-type))
538 (patches (sequence %store-monad
539 (map instantiate-patch patches))))
541 (with-imported-modules '((guix build utils))
543 (use-modules (ice-9 ftw)
547 ;; The --sort option was added to GNU tar in version 1.28, released
548 ;; 2014-07-28. During bootstrap we must cope with older versions.
549 (define tar-supports-sort?
550 (zero? (system* (string-append #+tar "/bin/tar")
551 "cf" "/dev/null" "--files-from=/dev/null"
554 (define (apply-patch patch)
555 (format (current-error-port) "applying '~a'...~%" patch)
557 ;; Use '--force' so that patches that do not apply perfectly are
558 ;; rejected. Use '--no-backup-if-mismatch' to prevent making
559 ;; "*.orig" file if a patch is applied with offset.
560 (invoke (string-append #+patch "/bin/patch")
561 "--force" "--no-backup-if-mismatch"
562 #+@flags "--input" patch))
564 (define (first-file directory)
565 ;; Return the name of the first file in DIRECTORY.
566 (car (scandir directory
568 (not (member name '("." "..")))))))
570 ;; Encoding/decoding errors shouldn't be silent.
571 (fluid-set! %default-port-conversion-strategy 'error)
574 ;; First of all, install a UTF-8 locale so that UTF-8 file names
575 ;; are correctly interpreted. During bootstrap, LOCALES is #f.
577 (string-append #+locales "/lib/locale/"
580 (package-version locales)))))
581 (setlocale LC_ALL "en_US.utf8"))
583 (setenv "PATH" (string-append #+xz "/bin" ":"
586 ;; SOURCE may be either a directory or a tarball.
587 (if (file-is-directory? #+source)
588 (let* ((store (%store-directory))
589 (len (+ 1 (string-length store)))
590 (base (string-drop #+source len))
591 (dash (string-index base #\-))
592 (directory (string-drop base (+ 1 dash))))
594 (copy-recursively #+source directory))
595 #+(if (string=? decompression-type "unzip")
596 #~(invoke "unzip" #+source)
597 #~(invoke (string-append #+tar "/bin/tar")
600 (let ((directory (first-file ".")))
601 (format (current-error-port)
602 "source is under '~a'~%" directory)
605 (for-each apply-patch '#+patches)
607 (let ((result #+(if snippet
608 #~(let ((module (make-fresh-user-module)))
609 (module-use-interfaces!
611 (map resolve-interface '#+modules))
612 ((@ (system base compile) compile)
615 #:opts %auto-compilation-options
618 ;; Issue a warning unless the result is #t.
619 (unless (eqv? result #t)
620 (format (current-error-port) "\
621 ## WARNING: the snippet returned `~s'. Return values other than #t
622 ## are deprecated. Please migrate this package so that its snippet
623 ## reports errors by raising an exception, and otherwise returns #t.~%"
626 (error "snippet returned false")))
630 (unless tar-supports-sort?
631 (call-with-output-file ".file_list"
633 (for-each (lambda (name)
634 (format port "~a~%" name))
635 (find-files directory
637 #:fail-on-error? #t)))))
639 (string-append #+tar "/bin/tar")
641 ;; avoid non-determinism in the archive
645 (if tar-supports-sort?
649 "--files-from=.file_list")))))))
651 (let ((name (tarxz-name original-file-name)))
652 (gexp->derivation name build
655 #:guile-for-build guile-for-build
656 #:properties `((type . origin)
657 (patches . ,(length patches)))))))
659 (define (package-with-patches original patches)
660 "Return package ORIGINAL with PATCHES applied."
661 (package (inherit original)
662 (source (origin (inherit (package-source original))
663 (patches patches)))))
665 (define (package-with-extra-patches original patches)
666 "Return package ORIGINAL with all PATCHES appended to its list of patches."
667 (package-with-patches original
668 (append (origin-patches (package-source original))
671 (define (transitive-inputs inputs)
672 "Return the closure of INPUTS when considering the 'propagated-inputs'
673 edges. Omit duplicate inputs, except for those already present in INPUTS
676 This is implemented as a breadth-first traversal such that INPUTS is
677 preserved, and only duplicate propagated inputs are removed."
678 (define (seen? seen item outputs)
679 ;; FIXME: We're using pointer identity here, which is extremely sensitive
680 ;; to memoization in package-producing procedures; see
681 ;; <https://bugs.gnu.org/30155>.
682 (match (vhash-assq item seen)
683 ((_ . o) (equal? o outputs))
686 (let loop ((inputs inputs)
693 (if (null? propagated)
695 (loop (reverse (concatenate propagated)) result '() #f seen)))
696 (((and input (label (? package? package) outputs ...)) rest ...)
697 (if (and (not first?) (seen? seen package outputs))
698 (loop rest result propagated first? seen)
701 (cons (package-propagated-inputs package) propagated)
703 (vhash-consq package outputs seen))))
705 (loop rest (cons input result) propagated first? seen)))))
707 (define (package-direct-sources package)
708 "Return all source origins associated with PACKAGE; including origins in
710 `(,@(or (and=> (package-source package) list) '())
711 ,@(filter-map (match-lambda
712 ((_ (? origin? orig) _ ...)
715 (package-direct-inputs package))))
717 (define (package-transitive-sources package)
718 "Return PACKAGE's direct sources, and their direct sources, recursively."
720 (concatenate (filter-map (match-lambda
721 ((_ (? origin? orig) _ ...)
723 ((_ (? package? p) _ ...)
724 (package-direct-sources p))
726 (bag-transitive-inputs
727 (package->bag package))))))
729 (define (package-direct-inputs package)
730 "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
731 with their propagated inputs."
732 (append (package-native-inputs package)
733 (package-inputs package)
734 (package-propagated-inputs package)))
736 (define (package-transitive-inputs package)
737 "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
738 with their propagated inputs, recursively."
739 (transitive-inputs (package-direct-inputs package)))
741 (define (package-transitive-target-inputs package)
742 "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
743 along with their propagated inputs, recursively. This only includes inputs
744 for the target system, and not native inputs."
745 (transitive-inputs (append (package-inputs package)
746 (package-propagated-inputs package))))
748 (define (package-transitive-native-inputs package)
749 "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
750 along with their propagated inputs, recursively. This only includes inputs
751 for the host system (\"native inputs\"), and not target inputs."
752 (transitive-inputs (package-native-inputs package)))
754 (define (package-transitive-propagated-inputs package)
755 "Return the propagated inputs of PACKAGE, and their propagated inputs,
757 (transitive-inputs (package-propagated-inputs package)))
759 (define (package-transitive-native-search-paths package)
760 "Return the list of search paths for PACKAGE and its propagated inputs,
762 (append (package-native-search-paths package)
763 (append-map (match-lambda
764 ((label (? package? p) _ ...)
765 (package-native-search-paths p))
768 (package-transitive-propagated-inputs package))))
770 (define (transitive-input-references alist inputs)
771 "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
772 in INPUTS and their transitive propagated inputs."
779 `(assoc-ref ,alist ,(label input)))
780 (transitive-inputs inputs)))
782 (define package-transitive-supported-systems
784 (define supported-systems
785 (mlambda (package system)
786 (parameterize ((%current-system system))
787 (fold (lambda (input systems)
789 ((label (? package? package) . _)
790 (lset-intersection string=? systems
791 (supported-systems package system)))
794 (package-supported-systems package)
795 (bag-direct-inputs (package->bag package))))))
797 (lambda* (package #:optional (system (%current-system)))
798 "Return the intersection of the systems supported by PACKAGE and those
799 supported by its dependencies."
800 (supported-systems package system))))
802 (define* (supported-package? package #:optional (system (%current-system)))
803 "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
804 dependencies are known to build on SYSTEM."
805 (member system (package-transitive-supported-systems package system)))
807 (define (bag-direct-inputs bag)
808 "Same as 'package-direct-inputs', but applied to a bag."
809 (append (bag-build-inputs bag)
810 (bag-host-inputs bag)
811 (bag-target-inputs bag)))
813 (define (bag-transitive-inputs bag)
814 "Same as 'package-transitive-inputs', but applied to a bag."
815 (transitive-inputs (bag-direct-inputs bag)))
817 (define (bag-transitive-build-inputs bag)
818 "Same as 'package-transitive-native-inputs', but applied to a bag."
819 (transitive-inputs (bag-build-inputs bag)))
821 (define (bag-transitive-host-inputs bag)
822 "Same as 'package-transitive-target-inputs', but applied to a bag."
823 (parameterize ((%current-target-system (bag-target bag)))
824 (transitive-inputs (bag-host-inputs bag))))
826 (define (bag-transitive-target-inputs bag)
827 "Return the \"target inputs\" of BAG, recursively."
828 (transitive-inputs (bag-target-inputs bag)))
830 (define* (package-closure packages #:key (system (%current-system)))
831 "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
832 packages they depend on, recursively."
833 (let loop ((packages packages)
835 (closure (list->setq packages)))
840 (if (vhash-assq package visited)
841 (loop rest visited closure)
842 (let* ((bag (package->bag package system))
843 (dependencies (filter-map (match-lambda
844 ((label (? package? package) . _)
847 (bag-direct-inputs bag))))
848 (loop (append dependencies rest)
849 (vhash-consq package #t visited)
850 (fold set-insert closure dependencies))))))))
852 (define* (package-mapping proc #:optional (cut? (const #f)))
853 "Return a procedure that, given a package, applies PROC to all the packages
854 depended on and returns the resulting package. The procedure stops recursion
855 when CUT? returns true for a given package."
856 (define (rewrite input)
858 ((label (? package? package) outputs ...)
859 (let ((proc (if (cut? package) proc replace)))
860 (cons* label (proc package) outputs)))
866 ;; Return a variant of P with PROC applied to P and its explicit
867 ;; dependencies, recursively. Memoize the transformations. Failing to
868 ;; do that, we would build a huge object graph with lots of duplicates,
869 ;; which in turns prevents us from benefiting from memoization in
870 ;; 'package-derivation'.
874 (location (package-location p))
875 (inputs (map rewrite (package-inputs p)))
876 (native-inputs (map rewrite (package-native-inputs p)))
877 (propagated-inputs (map rewrite (package-propagated-inputs p)))
878 (replacement (and=> (package-replacement p) proc))))))
882 (define* (package-input-rewriting replacements
883 #:optional (rewrite-name identity))
884 "Return a procedure that, when passed a package, replaces its direct and
885 indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
886 REPLACEMENTS is a list of package pairs; the first element of each pair is the
887 package to replace, and the second one is the replacement.
889 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
890 package and returns its new name after rewrite."
892 (match (assq-ref replacements p)
895 (name (rewrite-name (package-name p)))))
898 (package-mapping rewrite (cut assq <> replacements)))
900 (define (package-input-rewriting/spec replacements)
901 "Return a procedure that, given a package, applies the given REPLACEMENTS to
902 all the package graph (excluding implicit inputs). REPLACEMENTS is a list of
903 spec/procedures pair; each spec is a package specification such as \"gcc\" or
904 \"guile@2\", and each procedure takes a matching package and returns a
905 replacement for that package."
907 (fold (lambda (replacement table)
910 (let-values (((name version)
911 (package-name->name+version spec)))
912 (vhash-cons name (list version proc) table)))))
916 (define (find-replacement package)
917 (vhash-fold* (lambda (item proc)
923 (and (version-prefix? version
924 (package-version package))
927 (package-name package)
930 (define (rewrite package)
931 (match (find-replacement package)
933 (proc (proc package))))
935 (package-mapping rewrite find-replacement))
937 (define-syntax-rule (package/inherit p overrides ...)
938 "Like (package (inherit P) OVERRIDES ...), except that the same
939 transformation is done to the package replacement, if any. P must be a bare
940 identifier, and will be bound to either P or its replacement when evaluating
945 (replacement (and=> (package-replacement p) loop)))))
949 ;;; Package derivations.
952 (define %derivation-cache
953 ;; Package to derivation-path mapping.
954 (make-weak-key-hash-table 100))
956 (define (cache! cache package system thunk)
957 "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
959 ;; FIXME: This memoization should be associated with the open store, because
960 ;; otherwise it breaks when switching to a different store.
961 (let ((result (thunk)))
962 ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
963 ;; same value for all structs (as of Guile 2.0.6), and because pointer
964 ;; equality is sufficient in practice.
965 (hashq-set! cache package
966 `((,system . ,result)
967 ,@(or (hashq-ref cache package) '())))
970 (define-syntax cached
972 "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
973 Return the cached result when available."
974 ((_ (=> cache) package system body ...)
975 (let ((thunk (lambda () body ...))
977 (match (hashq-ref cache package)
979 (match (assoc-ref alist key)
980 (#f (cache! cache package key thunk))
983 (cache! cache package key thunk)))))
984 ((_ package system body ...)
985 (cached (=> %derivation-cache) package system body ...))))
987 (define* (expand-input store package input system #:optional cross-system)
988 "Expand INPUT, an input tuple, such that it contains only references to
989 derivation paths or store paths. PACKAGE is only used to provide contextual
990 information in exceptions."
991 (define (intern file)
992 ;; Add FILE to the store. Set the `recursive?' bit to #t, so that
993 ;; file permissions are preserved.
994 (add-to-store store (basename file) #t "sha256" file))
998 (cut package-cross-derivation store <> cross-system system
1000 (cut package-derivation store <> system #:graft? #f)))
1003 (((? string? name) (? package? package))
1004 (list name (derivation package)))
1005 (((? string? name) (? package? package)
1006 (? string? sub-drv))
1007 (list name (derivation package)
1010 (and (? string?) (? derivation-path?) drv))
1013 (and (? string?) (? file-exists? file)))
1014 ;; Add FILE to the store. When FILE is in the sub-directory of a
1015 ;; store path, it needs to be added anyway, so it can be used as a
1017 (list name (intern file)))
1018 (((? string? name) (? struct? source))
1019 ;; 'package-source-derivation' calls 'lower-object', which can throw
1020 ;; '&gexp-input-error'. However '&gexp-input-error' lacks source
1021 ;; location info, so we catch and rethrow here (XXX: not optimal
1022 ;; performance-wise).
1023 (guard (c ((gexp-input-error? c)
1025 (&package-input-error
1027 (input (gexp-error-invalid-input c)))))))
1028 (list name (package-source-derivation store source system))))
1030 (raise (condition (&package-input-error
1035 ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
1036 ;; It significantly speeds things up when doing repeated calls to
1037 ;; 'package->bag' as is the case when building a profile.
1038 (make-weak-key-hash-table 200))
1040 (define* (package->bag package #:optional
1041 (system (%current-system))
1042 (target (%current-target-system))
1043 #:key (graft? (%graft?)))
1044 "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
1046 (let ((package (or (and graft? (package-replacement package))
1048 (cached (=> %bag-cache)
1049 package (list system target)
1050 ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
1051 ;; field values can refer to it.
1052 (parameterize ((%current-system system)
1053 (%current-target-system target))
1056 ($ <package> name version source build-system
1057 args inputs propagated-inputs native-inputs
1059 ;; Even though we prefer to use "@" to separate the package
1060 ;; name from the package version in various user-facing parts
1061 ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
1062 ;; prohibits the use of "@", so use "-" instead.
1063 (or (make-bag build-system (string-append name "-" version)
1067 #:inputs (append (inputs self)
1068 (propagated-inputs self))
1070 #:native-inputs (native-inputs self)
1071 #:arguments (args self))
1074 (&package-cross-build-system-error
1078 (package package))))))))))))
1080 (define %graft-cache
1081 ;; 'eq?' cache mapping package objects to a graft corresponding to their
1082 ;; replacement package.
1083 (make-weak-key-hash-table 200))
1085 (define (input-graft store system)
1086 "Return a procedure that, given a package with a graft, returns a graft, and
1089 ((? package? package)
1090 (let ((replacement (package-replacement package)))
1092 (cached (=> %graft-cache) package system
1093 (let ((orig (package-derivation store package system
1095 (new (package-derivation store replacement system
1099 (replacement new)))))))
1103 (define (input-cross-graft store target system)
1104 "Same as 'input-graft', but for cross-compilation inputs."
1106 ((? package? package)
1107 (let ((replacement (package-replacement package)))
1109 (let ((orig (package-cross-derivation store package target system
1111 (new (package-cross-derivation store replacement
1116 (replacement new))))))
1120 (define* (fold-bag-dependencies proc seed bag
1122 "Fold PROC over the packages BAG depends on. Each package is visited only
1123 once, in depth-first order. If NATIVE? is true, restrict to native
1124 dependencies; otherwise, restrict to target dependencies."
1125 (define bag-direct-inputs*
1128 (append (bag-build-inputs bag)
1129 (bag-target-inputs bag)
1130 (if (bag-target bag)
1132 (bag-host-inputs bag))))
1136 (match (bag-direct-inputs* bag)
1137 (((labels things _ ...) ...)
1140 (let loop ((nodes nodes)
1146 (((? package? head) . tail)
1147 (if (set-contains? visited head)
1148 (loop tail result visited)
1149 (let ((inputs (bag-direct-inputs* (package->bag head))))
1151 (((labels things _ ...) ...)
1152 (append things tail)))
1154 (set-insert head visited)))))
1156 (loop tail result visited)))))
1158 (define* (bag-grafts store bag)
1159 "Return the list of grafts potentially applicable to BAG. Potentially
1160 applicable grafts are collected by looking at direct or indirect dependencies
1161 of BAG that have a 'replacement'. Whether a graft is actually applicable
1162 depends on whether the outputs of BAG depend on the items the grafts refer
1163 to (see 'graft-derivation'.)"
1164 (define system (bag-system bag))
1165 (define target (bag-target bag))
1167 (define native-grafts
1168 (let ((->graft (input-graft store system)))
1169 (fold-bag-dependencies (lambda (package grafts)
1170 (match (->graft package)
1172 (graft (cons graft grafts))))
1176 (define target-grafts
1178 (let ((->graft (input-cross-graft store target system)))
1179 (fold-bag-dependencies (lambda (package grafts)
1180 (match (->graft package)
1182 (graft (cons graft grafts))))
1188 ;; We can end up with several identical grafts if we stumble upon packages
1189 ;; that are not 'eq?' but map to the same derivation (this can happen when
1190 ;; using things like 'package-with-explicit-inputs'.) Hence the
1191 ;; 'delete-duplicates' call.
1193 (append native-grafts target-grafts)))
1195 (define* (package-grafts store package
1196 #:optional (system (%current-system))
1198 "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1200 (let* ((package (or (package-replacement package) package))
1201 (bag (package->bag package system target)))
1202 (bag-grafts store bag)))
1204 (define* (bag->derivation store bag
1206 "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
1207 a package object describing the context in which the call occurs, for improved
1209 (if (bag-target bag)
1210 (bag->cross-derivation store bag)
1211 (let* ((system (bag-system bag))
1212 (inputs (bag-transitive-inputs bag))
1213 (input-drvs (map (cut expand-input store context <> system)
1215 (paths (delete-duplicates
1216 (append-map (match-lambda
1217 ((_ (? package? p) _ ...)
1218 (package-native-search-paths
1223 (apply (bag-build bag)
1224 store (bag-name bag) input-drvs
1225 #:search-paths paths
1226 #:outputs (bag-outputs bag) #:system system
1227 (bag-arguments bag)))))
1229 (define* (bag->cross-derivation store bag
1231 "Return the derivation to build BAG, which is actually a cross build.
1232 Optionally, CONTEXT can be a package object denoting the context of the call.
1233 This is an internal procedure."
1234 (let* ((system (bag-system bag))
1235 (target (bag-target bag))
1236 (host (bag-transitive-host-inputs bag))
1237 (host-drvs (map (cut expand-input store context <> system target)
1239 (target* (bag-transitive-target-inputs bag))
1240 (target-drvs (map (cut expand-input store context <> system)
1242 (build (bag-transitive-build-inputs bag))
1243 (build-drvs (map (cut expand-input store context <> system)
1245 (all (append build target* host))
1246 (paths (delete-duplicates
1247 (append-map (match-lambda
1248 ((_ (? package? p) _ ...)
1249 (package-search-paths p))
1252 (npaths (delete-duplicates
1253 (append-map (match-lambda
1254 ((_ (? package? p) _ ...)
1255 (package-native-search-paths
1260 (apply (bag-build bag)
1261 store (bag-name bag)
1262 #:native-drvs build-drvs
1263 #:target-drvs (append host-drvs target-drvs)
1264 #:search-paths paths
1265 #:native-search-paths npaths
1266 #:outputs (bag-outputs bag)
1267 #:system system #:target target
1268 (bag-arguments bag))))
1270 (define* (package-derivation store package
1271 #:optional (system (%current-system))
1272 #:key (graft? (%graft?)))
1273 "Return the <derivation> object of PACKAGE for SYSTEM."
1275 ;; Compute the derivation and cache the result. Caching is important
1276 ;; because some derivations, such as the implicit inputs of the GNU build
1277 ;; system, will be queried many, many times in a row.
1278 (cached package (cons system graft?)
1279 (let* ((bag (package->bag package system #f #:graft? graft?))
1280 (drv (bag->derivation store bag package)))
1282 (match (bag-grafts store bag)
1286 (let ((guile (package-derivation store (guile-for-grafts)
1287 system #:graft? #f)))
1288 ;; TODO: As an optimization, we can simply graft the tip
1289 ;; of the derivation graph since 'graft-derivation'
1291 (graft-derivation store drv grafts
1296 (define* (package-cross-derivation store package target
1297 #:optional (system (%current-system))
1298 #:key (graft? (%graft?)))
1299 "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1300 system identifying string)."
1301 (cached package (list system target graft?)
1302 (let* ((bag (package->bag package system target #:graft? graft?))
1303 (drv (bag->derivation store bag package)))
1305 (match (bag-grafts store bag)
1309 (graft-derivation store drv grafts
1312 (package-derivation store (guile-for-grafts)
1313 system #:graft? #f))))
1316 (define* (package-output store package
1317 #:optional (output "out") (system (%current-system)))
1318 "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1319 symbolic output name, such as \"out\". Note that this procedure calls
1320 `package-derivation', which is costly."
1321 (let ((drv (package-derivation store package system)))
1322 (derivation->output-path drv output)))
1326 ;;; Monadic interface.
1329 (define (set-guile-for-build guile)
1330 "This monadic procedure changes the Guile currently used to run the build
1331 code of derivations to GUILE, a package object."
1333 (let ((guile (package-derivation store guile)))
1334 (values (%guile-for-build guile) store))))
1336 (define* (package-file package
1339 system (output "out") target)
1340 "Return as a monadic value the absolute file name of FILE within the
1341 OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
1342 OUTPUT directory of PACKAGE. When TARGET is true, use it as a
1343 cross-compilation target triplet."
1345 (define compute-derivation
1347 (cut package-cross-derivation <> <> target <>)
1348 package-derivation))
1350 (let* ((system (or system (%current-system)))
1351 (drv (compute-derivation store package system))
1352 (out (derivation->output-path drv output)))
1354 (string-append out "/" file)
1358 (define package->derivation
1359 (store-lift package-derivation))
1361 (define package->cross-derivation
1362 (store-lift package-cross-derivation))
1364 (define-gexp-compiler (package-compiler (package <package>) system target)
1365 ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1366 ;; TARGET. This is used when referring to a package from within a gexp.
1368 (package->cross-derivation package target system)
1369 (package->derivation package system)))
1371 (define* (origin->derivation origin
1372 #:optional (system (%current-system)))
1373 "Return the derivation corresponding to ORIGIN."
1375 (($ <origin> uri method sha256 name (= force ()) #f)
1376 ;; No patches, no snippet: this is a fixed-output derivation.
1377 (method uri 'sha256 sha256 name #:system system))
1378 (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1379 (flags ...) inputs (modules ...) guile-for-build)
1380 ;; Patches and/or a snippet.
1381 (mlet %store-monad ((source (method uri 'sha256 sha256 name
1383 (guile (package->derivation (or guile-for-build
1387 (patch-and-repack source patches
1393 #:guile-for-build guile)))))
1395 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
1396 ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
1397 ;; to an origin from within a gexp.
1398 (origin->derivation origin system))
1400 (define package-source-derivation ;somewhat deprecated
1401 (let ((lower (store-lower lower-object)))
1402 (lambda* (store source #:optional (system (%current-system)))
1403 "Return the derivation or file corresponding to SOURCE, which can be an
1404 a file name or any object handled by 'lower-object', such as an <origin>.
1405 When SOURCE is a file name, return either the interned file name (if SOURCE is
1406 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1408 ((and (? string?) (? direct-store-path?) file)
1411 (add-to-store store (basename file) #t "sha256" file))
1413 (lower store source system))))))