1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
- ;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.org>
- ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
- ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
- ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- (define-module (guix packages)
- #:use-module (guix utils)
- #:use-module (guix records)
- #:use-module (guix store)
- #:use-module (guix monads)
- #:use-module (guix gexp)
- #:use-module (guix base32)
- #:use-module (guix grafts)
- #:use-module (guix derivations)
- #:use-module (guix memoization)
- #:use-module (guix build-system)
- #:use-module (guix search-paths)
- #:use-module (guix sets)
- #:use-module (ice-9 match)
- #:use-module (ice-9 vlist)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:use-module (web uri)
- #:re-export (%current-system
- %current-target-system
- search-path-specification) ;for convenience
- #:export (origin
- origin?
- origin-uri
- origin-method
- origin-sha256
- origin-file-name
- origin-actual-file-name
- origin-patches
- origin-patch-flags
- origin-patch-inputs
- origin-patch-guile
- origin-snippet
- origin-modules
- base32
- package
- package?
- package-name
- package-upstream-name
- package-version
- package-full-name
- package-source
- package-build-system
- package-arguments
- package-inputs
- package-native-inputs
- package-propagated-inputs
- package-outputs
- package-native-search-paths
- package-search-paths
- package-replacement
- package-synopsis
- package-description
- package-license
- package-home-page
- package-supported-systems
- package-maintainers
- package-properties
- package-location
- hidden-package
- hidden-package?
- package-superseded
- deprecated-package
- package-field-location
- package-direct-sources
- package-transitive-sources
- package-direct-inputs
- package-transitive-inputs
- package-transitive-target-inputs
- package-transitive-native-inputs
- package-transitive-propagated-inputs
- package-transitive-native-search-paths
- package-transitive-supported-systems
- package-mapping
- package-input-rewriting
- package-source-derivation
- package-derivation
- package-cross-derivation
- package-output
- package-grafts
- package/inherit
- transitive-input-references
- %supported-systems
- %hurd-systems
- %hydra-supported-systems
- supported-package?
- &package-error
- package-error?
- package-error-package
- &package-input-error
- package-input-error?
- package-error-invalid-input
- &package-cross-build-system-error
- package-cross-build-system-error?
- package->bag
- bag->derivation
- bag-direct-inputs
- bag-transitive-inputs
- bag-transitive-host-inputs
- bag-transitive-build-inputs
- bag-transitive-target-inputs
- default-guile
- default-guile-derivation
- set-guile-for-build
- package-file
- package->derivation
- package->cross-derivation
- origin->derivation))
- ;;; Commentary:
- ;;;
- ;;; This module provides a high-level mechanism to define packages in a
- ;;; Guix-based distribution.
- ;;;
- ;;; Code:
- ;; The source of a package, such as a tarball URL and fetcher---called
- ;; "origin" to avoid name clash with `package-source', `source', etc.
- (define-record-type* <origin>
- origin make-origin
- origin?
- (uri origin-uri) ; string
- (method origin-method) ; procedure
- (sha256 origin-sha256) ; bytevector
- (file-name origin-file-name (default #f)) ; optional file name
- ;; Patches are delayed so that the 'search-patch' calls are made lazily,
- ;; which reduces I/O on startup and allows patch-not-found errors to be
- ;; gracefully handled at run time.
- (patches origin-patches ; list of file names
- (default '()) (delayed))
- (snippet origin-snippet (default #f)) ; sexp or #f
- (patch-flags origin-patch-flags ; list of strings
- (default '("-p1")))
- ;; Patching requires Guile, GNU Patch, and a few more. These two fields are
- ;; used to specify these dependencies when needed.
- (patch-inputs origin-patch-inputs ; input list or #f
- (default #f))
- (modules origin-modules ; list of module names
- (default '()))
- (patch-guile origin-patch-guile ; package or #f
- (default #f)))
- (define (print-origin origin port)
- "Write a concise representation of ORIGIN to PORT."
- (match origin
- (($ <origin> uri method sha256 file-name patches)
- (simple-format port "#<origin ~s ~a ~s ~a>"
- uri (bytevector->base32-string sha256)
- (force patches)
- (number->string (object-address origin) 16)))))
- (set-record-type-printer! <origin> print-origin)
- (define-syntax base32
- (lambda (s)
- "Return the bytevector corresponding to the given Nix-base32
- representation."
- (syntax-case s ()
- ((_ str)
- (string? (syntax->datum #'str))
- ;; A literal string: do the conversion at expansion time.
- (with-syntax ((bv (nix-base32-string->bytevector
- (syntax->datum #'str))))
- #''bv))
- ((_ str)
- #'(nix-base32-string->bytevector str)))))
- (define (origin-actual-file-name origin)
- "Return the file name of ORIGIN, either its 'file-name' field or the file
- name of its URI."
- (define (uri->file-name uri)
- ;; Return the 'base name' of URI or URI itself, where URI is a string.
- (let ((path (and=> (string->uri uri) uri-path)))
- (if path
- (basename path)
- uri)))
- (or (origin-file-name origin)
- (match (origin-uri origin)
- ((head . tail)
- (uri->file-name head))
- ((? string? uri)
- (uri->file-name uri))
- (else
- ;; git, svn, cvs, etc. reference
- #f))))
- (define %supported-systems
- ;; This is the list of system types that are supported. By default, we
- ;; expect all packages to build successfully here.
- '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux"))
- (define %hurd-systems
- ;; The GNU/Hurd systems for which support is being developed.
- '("i585-gnu" "i686-gnu"))
- (define %hydra-supported-systems
- ;; This is the list of system types for which build machines are available.
- ;;
- ;; XXX: MIPS is temporarily unavailable on Hydra:
- ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
- (fold delete %supported-systems '("aarch64-linux" "mips64el-linux")))
- ;; A package.
- (define-record-type* <package>
- package make-package
- package?
- (name package-name) ; string
- (version package-version) ; string
- (source package-source) ; <origin> instance
- (build-system package-build-system) ; build system
- (arguments package-arguments ; arguments for the build method
- (default '()) (thunked))
- (inputs package-inputs ; input packages or derivations
- (default '()) (thunked))
- (propagated-inputs package-propagated-inputs ; same, but propagated
- (default '()) (thunked))
- (native-inputs package-native-inputs ; native input packages/derivations
- (default '()) (thunked))
- (self-native-input? package-self-native-input? ; whether to use itself as
- ; a native input when cross-
- (default #f)) ; compiling
- (outputs package-outputs ; list of strings
- (default '("out")))
- ; lists of
- ; <search-path-specification>,
- ; for native and cross
- ; inputs
- (native-search-paths package-native-search-paths (default '()))
- (search-paths package-search-paths (default '()))
- ;; The 'replacement' field is marked as "innate" because it never makes
- ;; sense to inherit a replacement as is. See the 'package/inherit' macro.
- (replacement package-replacement ; package | #f
- (default #f) (thunked) (innate))
- (synopsis package-synopsis) ; one-line description
- (description package-description) ; one or two paragraphs
- (license package-license)
- (home-page package-home-page)
- (supported-systems package-supported-systems ; list of strings
- (default %supported-systems))
- (maintainers package-maintainers (default '()))
- (properties package-properties (default '())) ; alist for anything else
- (location package-location
- (default (and=> (current-source-location)
- source-properties->location))
- (innate)))
- (set-record-type-printer! <package>
- (lambda (package port)
- (let ((loc (package-location package))
- (format simple-format))
- (format port "#<package ~a@~a ~a~a>"
- (package-name package)
- (package-version package)
- (if loc
- (format #f "~a:~a "
- (location-file loc)
- (location-line loc))
- "")
- (number->string (object-address
- package)
- 16)))))
- (define (package-upstream-name package)
- "Return the upstream name of PACKAGE, which could be different from the name
- it has in Guix."
- (or (assq-ref (package-properties package) 'upstream-name)
- (package-name package)))
- (define (hidden-package p)
- "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
- user interfaces, ignores."
- (package
- (inherit p)
- (properties `((hidden? . #t)
- ,@(package-properties p)))))
- (define (hidden-package? p)
- "Return true if P is \"hidden\"--i.e., must not be visible to user
- interfaces."
- (assoc-ref (package-properties p) 'hidden?))
- (define (package-superseded p)
- "Return the package the supersedes P, or #f if P is still current."
- (assoc-ref (package-properties p) 'superseded))
- (define (deprecated-package old-name p)
- "Return a package called OLD-NAME and marked as superseded by P, a package
- object."
- (package
- (inherit p)
- (name old-name)
- (properties `((superseded . ,p)))))
- (define (package-field-location package field)
- "Return the source code location of the definition of FIELD for PACKAGE, or
- #f if it could not be determined."
- (define (goto port line column)
- (unless (and (= (port-column port) (- column 1))
- (= (port-line port) (- line 1)))
- (unless (eof-object? (read-char port))
- (goto port line column))))
- (match (package-location package)
- (($ <location> file line column)
- (catch 'system
- (lambda ()
- ;; In general we want to keep relative file names for modules.
- (with-fluids ((%file-port-name-canonicalization 'relative))
- (call-with-input-file (search-path %load-path file)
- (lambda (port)
- (goto port line column)
- (match (read port)
- (('package inits ...)
- (let ((field (assoc field inits)))
- (match field
- ((_ value)
- ;; Put the `or' here, and not in the first argument of
- ;; `and=>', to work around a compiler bug in 2.0.5.
- (or (and=> (source-properties value)
- source-properties->location)
- (and=> (source-properties field)
- source-properties->location)))
- (_
- #f))))
- (_
- #f))))))
- (lambda _
- #f)))
- (_ #f)))
- ;; Error conditions.
- (define-condition-type &package-error &error
- package-error?
- (package package-error-package))
- (define-condition-type &package-input-error &package-error
- package-input-error?
- (input package-error-invalid-input))
- (define-condition-type &package-cross-build-system-error &package-error
- package-cross-build-system-error?)
- (define (package-full-name package)
- "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
- (string-append (package-name package) "-" (package-version package)))
- (define (%standard-patch-inputs)
- (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
- 'canonical-package))
- (ref (lambda (module var)
- (canonical
- (module-ref (resolve-interface module) var)))))
- `(("tar" ,(ref '(gnu packages base) 'tar))
- ("xz" ,(ref '(gnu packages compression) 'xz))
- ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
- ("gzip" ,(ref '(gnu packages compression) 'gzip))
- ("lzip" ,(ref '(gnu packages compression) 'lzip))
- ("unzip" ,(ref '(gnu packages compression) 'unzip))
- ("patch" ,(ref '(gnu packages base) 'patch))
- ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
- (define (default-guile)
- "Return the default Guile package used to run the build code of
- derivations."
- (let ((distro (resolve-interface '(gnu packages commencement))))
- (module-ref distro 'guile-final)))
- (define (guile-2.0)
- "Return Guile 2.0."
- ;; FIXME: This is used as a workaround for <https://bugs.gnu.org/28211> when
- ;; grafting packages.
- (let ((distro (resolve-interface '(gnu packages guile))))
- (module-ref distro 'guile-2.0)))
- (define* (default-guile-derivation #:optional (system (%current-system)))
- "Return the derivation for SYSTEM of the default Guile package used to run
- the build code of derivation."
- (package->derivation (default-guile) system
- #:graft? #f))
- (define* (patch-and-repack source patches
- #:key
- inputs
- (snippet #f)
- (flags '("-p1"))
- (modules '())
- (guile-for-build (%guile-for-build))
- (system (%current-system)))
- "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
- repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
- it must be an s-expression that will run from within the directory where
- SOURCE was unpacked, after all of PATCHES have been applied. MODULES
- specifies modules in scope when evaluating SNIPPET."
- (define source-file-name
- ;; SOURCE is usually a derivation, but it could be a store file.
- (if (derivation? source)
- (derivation->output-path source)
- source))
- (define lookup-input
- ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
- ;; so deal with that.
- (let ((inputs (or inputs (%standard-patch-inputs))))
- (lambda (name)
- (match (assoc-ref inputs name)
- ((package) package)
- (#f #f)))))
- (define decompression-type
- (cond ((string-suffix? "gz" source-file-name) "gzip")
- ((string-suffix? "Z" source-file-name) "gzip")
- ((string-suffix? "bz2" source-file-name) "bzip2")
- ((string-suffix? "lz" source-file-name) "lzip")
- ((string-suffix? "zip" source-file-name) "unzip")
- (else "xz")))
- (define original-file-name
- ;; Remove the store prefix plus the slash, hash, and hyphen.
- (let* ((sans (string-drop source-file-name
- (+ (string-length (%store-prefix)) 1)))
- (dash (string-index sans #\-)))
- (string-drop sans (+ 1 dash))))
- (define (numeric-extension? file-name)
- ;; Return true if FILE-NAME ends with digits.
- (and=> (file-extension file-name)
- (cut string-every char-set:hex-digit <>)))
- (define (tarxz-name file-name)
- ;; Return a '.tar.xz' file name based on FILE-NAME.
- (let ((base (if (numeric-extension? file-name)
- original-file-name
- (file-sans-extension file-name))))
- (string-append base
- (if (equal? (file-extension base) "tar")
- ".xz"
- ".tar.xz"))))
- (define instantiate-patch
- (match-lambda
- ((? string? patch) ;deprecated
- (interned-file patch #:recursive? #t))
- ((? struct? patch) ;origin, local-file, etc.
- (lower-object patch system))))
- (mlet %store-monad ((tar -> (lookup-input "tar"))
- (xz -> (lookup-input "xz"))
- (patch -> (lookup-input "patch"))
- (locales -> (lookup-input "locales"))
- (decomp -> (lookup-input decompression-type))
- (patches (sequence %store-monad
- (map instantiate-patch patches))))
- (define build
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (ice-9 ftw)
- (srfi srfi-1)
- (guix build utils))
- ;; The --sort option was added to GNU tar in version 1.28, released
- ;; 2014-07-28. During bootstrap we must cope with older versions.
- (define tar-supports-sort?
- (zero? (system* (string-append #+tar "/bin/tar")
- "cf" "/dev/null" "--files-from=/dev/null"
- "--sort=name")))
- (define (apply-patch patch)
- (format (current-error-port) "applying '~a'...~%" patch)
- ;; Use '--force' so that patches that do not apply perfectly are
- ;; rejected. Use '--no-backup-if-mismatch' to prevent making
- ;; "*.orig" file if a patch is applied with offset.
- (zero? (system* (string-append #+patch "/bin/patch")
- "--force" "--no-backup-if-mismatch"
- #+@flags "--input" patch)))
- (define (first-file directory)
- ;; Return the name of the first file in DIRECTORY.
- (car (scandir directory
- (lambda (name)
- (not (member name '("." "..")))))))
- ;; Encoding/decoding errors shouldn't be silent.
- (fluid-set! %default-port-conversion-strategy 'error)
- (when #+locales
- ;; First of all, install a UTF-8 locale so that UTF-8 file names
- ;; are correctly interpreted. During bootstrap, LOCALES is #f.
- (setenv "LOCPATH"
- (string-append #+locales "/lib/locale/"
- #+(and locales
- (package-version locales))))
- (setlocale LC_ALL "en_US.utf8"))
- (setenv "PATH" (string-append #+xz "/bin" ":"
- #+decomp "/bin"))
- ;; SOURCE may be either a directory or a tarball.
- (and (if (file-is-directory? #+source)
- (let* ((store (%store-directory))
- (len (+ 1 (string-length store)))
- (base (string-drop #+source len))
- (dash (string-index base #\-))
- (directory (string-drop base (+ 1 dash))))
- (mkdir directory)
- (copy-recursively #+source directory)
- #t)
- #+(if (string=? decompression-type "unzip")
- #~(zero? (system* "unzip" #+source))
- #~(zero? (system* (string-append #+tar "/bin/tar")
- "xvf" #+source))))
- (let ((directory (first-file ".")))
- (format (current-error-port)
- "source is under '~a'~%" directory)
- (chdir directory)
- (and (every apply-patch '#+patches)
- #+@(if snippet
- #~((let ((module (make-fresh-user-module)))
- (module-use-interfaces!
- module
- (map resolve-interface '#+modules))
- ((@ (system base compile) compile)
- '#+snippet
- #:to 'value
- #:opts %auto-compilation-options
- #:env module)))
- #~())
- (begin (chdir "..") #t)
- (unless tar-supports-sort?
- (call-with-output-file ".file_list"
- (lambda (port)
- (for-each (lambda (name)
- (format port "~a~%" name))
- (find-files directory
- #:directories? #t
- #:fail-on-error? #t)))))
- (zero? (apply system*
- (string-append #+tar "/bin/tar")
- "cvf" #$output
- ;; The bootstrap xz does not support
- ;; threaded compression (introduced in
- ;; 5.2.0), but it ignores the extra flag.
- (string-append "--use-compress-program="
- #+xz "/bin/xz --threads=0")
- ;; avoid non-determinism in the archive
- "--mtime=@0"
- "--owner=root:0"
- "--group=root:0"
- (if tar-supports-sort?
- `("--sort=name"
- ,directory)
- '("--no-recursion"
- "--files-from=.file_list"))))))))))
- (let ((name (tarxz-name original-file-name)))
- (gexp->derivation name build
- #:graft? #f
- #:system system
- #:deprecation-warnings #t ;to avoid a rebuild
- #:guile-for-build guile-for-build))))
- (define (transitive-inputs inputs)
- "Return the closure of INPUTS when considering the 'propagated-inputs'
- edges. Omit duplicate inputs, except for those already present in INPUTS
- itself.
- This is implemented as a breadth-first traversal such that INPUTS is
- preserved, and only duplicate propagated inputs are removed."
- (define (seen? seen item outputs)
- (match (vhash-assq item seen)
- ((_ . o) (equal? o outputs))
- (_ #f)))
- (let loop ((inputs inputs)
- (result '())
- (propagated '())
- (first? #t)
- (seen vlist-null))
- (match inputs
- (()
- (if (null? propagated)
- (reverse result)
- (loop (reverse (concatenate propagated)) result '() #f seen)))
- (((and input (label (? package? package) outputs ...)) rest ...)
- (if (and (not first?) (seen? seen package outputs))
- (loop rest result propagated first? seen)
- (loop rest
- (cons input result)
- (cons (package-propagated-inputs package) propagated)
- first?
- (vhash-consq package outputs seen))))
- ((input rest ...)
- (loop rest (cons input result) propagated first? seen)))))
- (define (package-direct-sources package)
- "Return all source origins associated with PACKAGE; including origins in
- PACKAGE's inputs."
- `(,@(or (and=> (package-source package) list) '())
- ,@(filter-map (match-lambda
- ((_ (? origin? orig) _ ...)
- orig)
- (_ #f))
- (package-direct-inputs package))))
- (define (package-transitive-sources package)
- "Return PACKAGE's direct sources, and their direct sources, recursively."
- (delete-duplicates
- (concatenate (filter-map (match-lambda
- ((_ (? origin? orig) _ ...)
- (list orig))
- ((_ (? package? p) _ ...)
- (package-direct-sources p))
- (_ #f))
- (bag-transitive-inputs
- (package->bag package))))))
- (define (package-direct-inputs package)
- "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
- with their propagated inputs."
- (append (package-native-inputs package)
- (package-inputs package)
- (package-propagated-inputs package)))
- (define (package-transitive-inputs package)
- "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
- with their propagated inputs, recursively."
- (transitive-inputs (package-direct-inputs package)))
- (define (package-transitive-target-inputs package)
- "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
- along with their propagated inputs, recursively. This only includes inputs
- for the target system, and not native inputs."
- (transitive-inputs (append (package-inputs package)
- (package-propagated-inputs package))))
- (define (package-transitive-native-inputs package)
- "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
- along with their propagated inputs, recursively. This only includes inputs
- for the host system (\"native inputs\"), and not target inputs."
- (transitive-inputs (package-native-inputs package)))
- (define (package-transitive-propagated-inputs package)
- "Return the propagated inputs of PACKAGE, and their propagated inputs,
- recursively."
- (transitive-inputs (package-propagated-inputs package)))
- (define (package-transitive-native-search-paths package)
- "Return the list of search paths for PACKAGE and its propagated inputs,
- recursively."
- (append (package-native-search-paths package)
- (append-map (match-lambda
- ((label (? package? p) _ ...)
- (package-native-search-paths p))
- (_
- '()))
- (package-transitive-propagated-inputs package))))
- (define (transitive-input-references alist inputs)
- "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
- in INPUTS and their transitive propagated inputs."
- (define label
- (match-lambda
- ((label . _)
- label)))
- (map (lambda (input)
- `(assoc-ref ,alist ,(label input)))
- (transitive-inputs inputs)))
- (define package-transitive-supported-systems
- (mlambdaq (package)
- "Return the intersection of the systems supported by PACKAGE and those
- supported by its dependencies."
- (fold (lambda (input systems)
- (match input
- ((label (? package? p) . _)
- (lset-intersection
- string=? systems (package-transitive-supported-systems p)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package)))))
- (define* (supported-package? package #:optional (system (%current-system)))
- "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
- dependencies are known to build on SYSTEM."
- (member system (package-transitive-supported-systems package)))
- (define (bag-direct-inputs bag)
- "Same as 'package-direct-inputs', but applied to a bag."
- (append (bag-build-inputs bag)
- (bag-host-inputs bag)
- (bag-target-inputs bag)))
- (define (bag-transitive-inputs bag)
- "Same as 'package-transitive-inputs', but applied to a bag."
- (transitive-inputs (bag-direct-inputs bag)))
- (define (bag-transitive-build-inputs bag)
- "Same as 'package-transitive-native-inputs', but applied to a bag."
- (transitive-inputs (bag-build-inputs bag)))
- (define (bag-transitive-host-inputs bag)
- "Same as 'package-transitive-target-inputs', but applied to a bag."
- (transitive-inputs (bag-host-inputs bag)))
- (define (bag-transitive-target-inputs bag)
- "Return the \"target inputs\" of BAG, recursively."
- (transitive-inputs (bag-target-inputs bag)))
- (define* (package-mapping proc #:optional (cut? (const #f)))
- "Return a procedure that, given a package, applies PROC to all the packages
- depended on and returns the resulting package. The procedure stops recursion
- when CUT? returns true for a given package."
- (define (rewrite input)
- (match input
- ((label (? package? package) outputs ...)
- (let ((proc (if (cut? package) proc replace)))
- (cons* label (proc package) outputs)))
- (_
- input)))
- (define replace
- (mlambdaq (p)
- ;; Return a variant of P with PROC applied to P and its explicit
- ;; dependencies, recursively. Memoize the transformations. Failing to
- ;; do that, we would build a huge object graph with lots of duplicates,
- ;; which in turns prevents us from benefiting from memoization in
- ;; 'package-derivation'.
- (let ((p (proc p)))
- (package
- (inherit p)
- (location (package-location p))
- (inputs (map rewrite (package-inputs p)))
- (native-inputs (map rewrite (package-native-inputs p)))
- (propagated-inputs (map rewrite (package-propagated-inputs p)))))))
- replace)
- (define* (package-input-rewriting replacements
- #:optional (rewrite-name identity))
- "Return a procedure that, when passed a package, replaces its direct and
- indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
- REPLACEMENTS is a list of package pairs; the first element of each pair is the
- package to replace, and the second one is the replacement.
- Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
- package and returns its new name after rewrite."
- (define (rewrite p)
- (match (assq-ref replacements p)
- (#f (package
- (inherit p)
- (name (rewrite-name (package-name p)))))
- (new new)))
- (package-mapping rewrite (cut assq <> replacements)))
- (define-syntax-rule (package/inherit p overrides ...)
- "Like (package (inherit P) OVERRIDES ...), except that the same
- transformation is done to the package replacement, if any. P must be a bare
- identifier, and will be bound to either P or its replacement when evaluating
- OVERRIDES."
- (let loop ((p p))
- (package (inherit p)
- overrides ...
- (replacement (and=> (package-replacement p) loop)))))
- ;;;
- ;;; Package derivations.
- ;;;
- (define %derivation-cache
- ;; Package to derivation-path mapping.
- (make-weak-key-hash-table 100))
- (define (cache! cache package system thunk)
- "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
- SYSTEM."
- ;; FIXME: This memoization should be associated with the open store, because
- ;; otherwise it breaks when switching to a different store.
- (let ((vals (call-with-values thunk list)))
- ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
- ;; same value for all structs (as of Guile 2.0.6), and because pointer
- ;; equality is sufficient in practice.
- (hashq-set! cache package
- `((,system ,@vals)
- ,@(or (hashq-ref cache package) '())))
- (apply values vals)))
- (define-syntax cached
- (syntax-rules (=>)
- "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
- Return the cached result when available."
- ((_ (=> cache) package system body ...)
- (let ((thunk (lambda () body ...))
- (key system))
- (match (hashq-ref cache package)
- ((alist (... ...))
- (match (assoc-ref alist key)
- ((vals (... ...))
- (apply values vals))
- (#f
- (cache! cache package key thunk))))
- (#f
- (cache! cache package key thunk)))))
- ((_ package system body ...)
- (cached (=> %derivation-cache) package system body ...))))
- (define* (expand-input store package input system #:optional cross-system)
- "Expand INPUT, an input tuple, such that it contains only references to
- derivation paths or store paths. PACKAGE is only used to provide contextual
- information in exceptions."
- (define (intern file)
- ;; Add FILE to the store. Set the `recursive?' bit to #t, so that
- ;; file permissions are preserved.
- (add-to-store store (basename file) #t "sha256" file))
- (define derivation
- (if cross-system
- (cut package-cross-derivation store <> cross-system system
- #:graft? #f)
- (cut package-derivation store <> system #:graft? #f)))
- (match input
- (((? string? name) (? package? package))
- (list name (derivation package)))
- (((? string? name) (? package? package)
- (? string? sub-drv))
- (list name (derivation package)
- sub-drv))
- (((? string? name)
- (and (? string?) (? derivation-path?) drv))
- (list name drv))
- (((? string? name)
- (and (? string?) (? file-exists? file)))
- ;; Add FILE to the store. When FILE is in the sub-directory of a
- ;; store path, it needs to be added anyway, so it can be used as a
- ;; source.
- (list name (intern file)))
- (((? string? name) (? struct? source))
- ;; 'package-source-derivation' calls 'lower-object', which can throw
- ;; '&gexp-input-error'. However '&gexp-input-error' lacks source
- ;; location info, so we catch and rethrow here (XXX: not optimal
- ;; performance-wise).
- (guard (c ((gexp-input-error? c)
- (raise (condition
- (&package-input-error
- (package package)
- (input (gexp-error-invalid-input c)))))))
- (list name (package-source-derivation store source system))))
- (x
- (raise (condition (&package-input-error
- (package package)
- (input x)))))))
- (define %bag-cache
- ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
- ;; It significantly speeds things up when doing repeated calls to
- ;; 'package->bag' as is the case when building a profile.
- (make-weak-key-hash-table 200))
- (define* (package->bag package #:optional
- (system (%current-system))
- (target (%current-target-system))
- #:key (graft? (%graft?)))
- "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
- and return it."
- (cached (=> %bag-cache)
- package (list system target graft?)
- ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
- ;; field values can refer to it.
- (parameterize ((%current-system system)
- (%current-target-system target))
- (match (if graft?
- (or (package-replacement package) package)
- package)
- (($ <package> name version source build-system
- args inputs propagated-inputs native-inputs
- self-native-input? outputs)
- (or (make-bag build-system (string-append name "-" version)
- #:system system
- #:target target
- #:source source
- #:inputs (append (inputs)
- (propagated-inputs))
- #:outputs outputs
- #:native-inputs `(,@(if (and target
- self-native-input?)
- `(("self" ,package))
- '())
- ,@(native-inputs))
- #:arguments (args))
- (raise (if target
- (condition
- (&package-cross-build-system-error
- (package package)))
- (condition
- (&package-error
- (package package)))))))))))
- (define %graft-cache
- ;; 'eq?' cache mapping package objects to a graft corresponding to their
- ;; replacement package.
- (make-weak-key-hash-table 200))
- (define (input-graft store system)
- "Return a procedure that, given a package with a graft, returns a graft, and
- #f otherwise."
- (match-lambda
- ((? package? package)
- (let ((replacement (package-replacement package)))
- (and replacement
- (cached (=> %graft-cache) package system
- (let ((orig (package-derivation store package system
- #:graft? #f))
- (new (package-derivation store replacement system
- #:graft? #t)))
- (graft
- (origin orig)
- (replacement new)))))))
- (x
- #f)))
- (define (input-cross-graft store target system)
- "Same as 'input-graft', but for cross-compilation inputs."
- (match-lambda
- ((? package? package)
- (let ((replacement (package-replacement package)))
- (and replacement
- (let ((orig (package-cross-derivation store package target system
- #:graft? #f))
- (new (package-cross-derivation store replacement
- target system
- #:graft? #t)))
- (graft
- (origin orig)
- (replacement new))))))
- (_
- #f)))
- (define* (fold-bag-dependencies proc seed bag
- #:key (native? #t))
- "Fold PROC over the packages BAG depends on. Each package is visited only
- once, in depth-first order. If NATIVE? is true, restrict to native
- dependencies; otherwise, restrict to target dependencies."
- (define bag-direct-inputs*
- (if native?
- (lambda (bag)
- (append (bag-build-inputs bag)
- (bag-target-inputs bag)
- (if (bag-target bag)
- '()
- (bag-host-inputs bag))))
- bag-host-inputs))
- (define nodes
- (match (bag-direct-inputs* bag)
- (((labels things _ ...) ...)
- things)))
- (let loop ((nodes nodes)
- (result seed)
- (visited (setq)))
- (match nodes
- (()
- result)
- (((? package? head) . tail)
- (if (set-contains? visited head)
- (loop tail result visited)
- (let ((inputs (bag-direct-inputs* (package->bag head))))
- (loop (match inputs
- (((labels things _ ...) ...)
- (append things tail)))
- (proc head result)
- (set-insert head visited)))))
- ((head . tail)
- (loop tail result visited)))))
- (define* (bag-grafts store bag)
- "Return the list of grafts potentially applicable to BAG. Potentially
- applicable grafts are collected by looking at direct or indirect dependencies
- of BAG that have a 'replacement'. Whether a graft is actually applicable
- depends on whether the outputs of BAG depend on the items the grafts refer
- to (see 'graft-derivation'.)"
- (define system (bag-system bag))
- (define target (bag-target bag))
- (define native-grafts
- (let ((->graft (input-graft store system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag)))
- (define target-grafts
- (if target
- (let ((->graft (input-cross-graft store target system)))
- (fold-bag-dependencies (lambda (package grafts)
- (match (->graft package)
- (#f grafts)
- (graft (cons graft grafts))))
- '()
- bag
- #:native? #f))
- '()))
- ;; We can end up with several identical grafts if we stumble upon packages
- ;; that are not 'eq?' but map to the same derivation (this can happen when
- ;; using things like 'package-with-explicit-inputs'.) Hence the
- ;; 'delete-duplicates' call.
- (delete-duplicates
- (append native-grafts target-grafts)))
- (define* (package-grafts store package
- #:optional (system (%current-system))
- #:key target)
- "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
- TARGET."
- (let* ((package (or (package-replacement package) package))
- (bag (package->bag package system target)))
- (bag-grafts store bag)))
- (define* (bag->derivation store bag
- #:optional context)
- "Return the derivation to build BAG for SYSTEM. Optionally, CONTEXT can be
- a package object describing the context in which the call occurs, for improved
- error reporting."
- (if (bag-target bag)
- (bag->cross-derivation store bag)
- (let* ((system (bag-system bag))
- (inputs (bag-transitive-inputs bag))
- (input-drvs (map (cut expand-input store context <> system)
- inputs))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- inputs))))
- (apply (bag-build bag)
- store (bag-name bag) input-drvs
- #:search-paths paths
- #:outputs (bag-outputs bag) #:system system
- (bag-arguments bag)))))
- (define* (bag->cross-derivation store bag
- #:optional context)
- "Return the derivation to build BAG, which is actually a cross build.
- Optionally, CONTEXT can be a package object denoting the context of the call.
- This is an internal procedure."
- (let* ((system (bag-system bag))
- (target (bag-target bag))
- (host (bag-transitive-host-inputs bag))
- (host-drvs (map (cut expand-input store context <> system target)
- host))
- (target* (bag-transitive-target-inputs bag))
- (target-drvs (map (cut expand-input store context <> system)
- target*))
- (build (bag-transitive-build-inputs bag))
- (build-drvs (map (cut expand-input store context <> system)
- build))
- (all (append build target* host))
- (paths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-search-paths p))
- (_ '()))
- all)))
- (npaths (delete-duplicates
- (append-map (match-lambda
- ((_ (? package? p) _ ...)
- (package-native-search-paths
- p))
- (_ '()))
- all))))
- (apply (bag-build bag)
- store (bag-name bag)
- #:native-drvs build-drvs
- #:target-drvs (append host-drvs target-drvs)
- #:search-paths paths
- #:native-search-paths npaths
- #:outputs (bag-outputs bag)
- #:system system #:target target
- (bag-arguments bag))))
- (define* (package-derivation store package
- #:optional (system (%current-system))
- #:key (graft? (%graft?)))
- "Return the <derivation> object of PACKAGE for SYSTEM."
- ;; Compute the derivation and cache the result. Caching is important
- ;; because some derivations, such as the implicit inputs of the GNU build
- ;; system, will be queried many, many times in a row.
- (cached package (cons system graft?)
- (let* ((bag (package->bag package system #f #:graft? graft?))
- (drv (bag->derivation store bag package)))
- (if graft?
- (match (bag-grafts store bag)
- (()
- drv)
- (grafts
- (let ((guile (package-derivation store (guile-2.0)
- system #:graft? #f)))
- ;; TODO: As an optimization, we can simply graft the tip
- ;; of the derivation graph since 'graft-derivation'
- ;; recurses anyway.
- (graft-derivation store drv grafts
- #:system system
- #:guile guile))))
- drv))))
- (define* (package-cross-derivation store package target
- #:optional (system (%current-system))
- #:key (graft? (%graft?)))
- "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
- system identifying string)."
- (cached package (list system target graft?)
- (let* ((bag (package->bag package system target #:graft? graft?))
- (drv (bag->derivation store bag package)))
- (if graft?
- (match (bag-grafts store bag)
- (()
- drv)
- (grafts
- (graft-derivation store drv grafts
- #:system system
- #:guile
- (package-derivation store (guile-2.0)
- system #:graft? #f))))
- drv))))
- (define* (package-output store package
- #:optional (output "out") (system (%current-system)))
- "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
- symbolic output name, such as \"out\". Note that this procedure calls
- `package-derivation', which is costly."
- (let ((drv (package-derivation store package system)))
- (derivation->output-path drv output)))
- ;;;
- ;;; Monadic interface.
- ;;;
- (define (set-guile-for-build guile)
- "This monadic procedure changes the Guile currently used to run the build
- code of derivations to GUILE, a package object."
- (lambda (store)
- (let ((guile (package-derivation store guile)))
- (values (%guile-for-build guile) store))))
- (define* (package-file package
- #:optional file
- #:key
- system (output "out") target)
- "Return as a monadic value the absolute file name of FILE within the
- OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
- OUTPUT directory of PACKAGE. When TARGET is true, use it as a
- cross-compilation target triplet."
- (lambda (store)
- (define compute-derivation
- (if target
- (cut package-cross-derivation <> <> target <>)
- package-derivation))
- (let* ((system (or system (%current-system)))
- (drv (compute-derivation store package system))
- (out (derivation->output-path drv output)))
- (values (if file
- (string-append out "/" file)
- out)
- store))))
- (define package->derivation
- (store-lift package-derivation))
- (define package->cross-derivation
- (store-lift package-cross-derivation))
- (define-gexp-compiler (package-compiler (package <package>) system target)
- ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
- ;; TARGET. This is used when referring to a package from within a gexp.
- (if target
- (package->cross-derivation package target system)
- (package->derivation package system)))
- (define* (origin->derivation origin
- #:optional (system (%current-system)))
- "Return the derivation corresponding to ORIGIN."
- (match origin
- (($ <origin> uri method sha256 name (= force ()) #f)
- ;; No patches, no snippet: this is a fixed-output derivation.
- (method uri 'sha256 sha256 name #:system system))
- (($ <origin> uri method sha256 name (= force (patches ...)) snippet
- (flags ...) inputs (modules ...) guile-for-build)
- ;; Patches and/or a snippet.
- (mlet %store-monad ((source (method uri 'sha256 sha256 name
- #:system system))
- (guile (package->derivation (or guile-for-build
- (default-guile))
- system
- #:graft? #f)))
- (patch-and-repack source patches
- #:inputs inputs
- #:snippet snippet
- #:flags flags
- #:system system
- #:modules modules
- #:guile-for-build guile)))))
- (define-gexp-compiler (origin-compiler (origin <origin>) system target)
- ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring
- ;; to an origin from within a gexp.
- (origin->derivation origin system))
- (define package-source-derivation ;somewhat deprecated
- (let ((lower (store-lower lower-object)))
- (lambda* (store source #:optional (system (%current-system)))
- "Return the derivation or file corresponding to SOURCE, which can be an
- a file name or any object handled by 'lower-object', such as an <origin>.
- When SOURCE is a file name, return either the interned file name (if SOURCE is
- outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
- (match source
- ((and (? string?) (? direct-store-path?) file)
- file)
- ((? string? file)
- (add-to-store store (basename file) #t "sha256" file))
- (_
- (lower store source system))))))
|