diff options
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/pack.scm | 111 | ||||
-rw-r--r-- | guix/build/texlive-build-system.scm | 265 |
2 files changed, 357 insertions, 19 deletions
diff --git a/guix/build/pack.scm b/guix/build/pack.scm index 3b73d1b227..fcb1da2a6c 100644 --- a/guix/build/pack.scm +++ b/guix/build/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,8 +17,25 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build pack) + #:use-module (gnu build install) #:use-module (guix build utils) - #:export (tar-base-options)) + #:use-module (guix build store-copy) + #:use-module ((guix build union) #:select (relative-file-name)) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (tar-base-options + populate-profile-root + build-self-contained-tarball)) + +;;; Commentary: + +;;; This module contains build-side common procedures used by the host-side +;;; (guix scripts pack) module, mostly to allow for code reuse. Due to making +;;; use of the (guix build store-copy) module, it transitively requires the +;;; sqlite and gcrypt extensions to be available. + +;;; Code: (define* (tar-base-options #:key tar compressor) "Return the base GNU tar options required to produce deterministic archives @@ -52,3 +69,93 @@ the `-I' option." ;; process. Use '--hard-dereference' to eliminate it. "--hard-dereference" "--check-links")) + +(define (assert-utf8-locale) + "Verify the current process is using the en_US.utf8 locale." + (unless (string=? "unset for tests" (getenv "GUIX_LOCPATH")) + (unless (false-if-exception (setlocale LC_ALL "en_US.utf8")) + (error "environment not configured for en_US.utf8 locale")))) + +(define* (populate-profile-root profile + #:key (profile-name "guix-profile") + localstatedir? + store-database + deduplicate? + (symlinks '())) + "Populate the root profile directory with SYMLINKS and a Guix database, when +LOCALSTATEDIR? is set, and a pre-computed STORE-DATABASE is provided. The +directory is created as \"root\" in the current working directory. When +DEDUPLICATE? is true, deduplicate the store items, which relies on hard +links. It needs to run in an environment where " + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives symlinks)) + + (define %root "root") + + (when localstatedir? + (unless store-database + (error "missing STORE-DATABASE argument"))) + + (assert-utf8-locale) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off by + ;; default. Furthermore GNU tar < 1.30 sometimes fails to extract + ;; tarballs with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-store (list "profile") %root #:deduplicate? deduplicate?) + + (when localstatedir? + (install-database-and-gc-roots %root store-database + profile #:profile-name profile-name)) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) directives)) + +(define* (build-self-contained-tarball profile + tarball-file-name + #:key (profile-name "guix-profile") + localstatedir? + store-database + deduplicate? + symlinks + compressor-command) + "Create a self-contained tarball TARBALL-FILE-NAME from PROFILE, optionally +compressing it with COMPRESSOR-COMMAND, the complete command-line string to +use for the compressor." + (populate-profile-root profile + #:profile-name profile-name + #:localstatedir? localstatedir? + #:store-database store-database + #:deduplicate? deduplicate? + #:symlinks symlinks) + + (assert-utf8-locale) + + ;; GNU Tar recurses directories by default. Simply add the whole root + ;; directory, which contains all the files to be archived. This avoids + ;; creating duplicate files in the archives that would be stored as hard + ;; links by GNU Tar. + (apply invoke "tar" "-cvf" tarball-file-name "-C" "root" "." + (tar-base-options + #:tar "tar" + #:compressor compressor-command))) diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index 353fb934a6..a9fe9c80cc 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Thiago Jung Bauermann <bauermann@kolabnow.com> +;;; Copyright © 2023 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,9 +23,11 @@ #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) #:use-module (guix build union) - #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:export (%standard-phases texlive-build)) @@ -35,36 +38,264 @@ ;; ;; Code: -(define (compile-with-latex engine format file) +(define (runfiles-root-directories) + "Return list of root directories containing runfiles." + (scandir "." + (negate + (cut member <> '("." ".." "build" "doc" "source"))))) + +(define (texlive-input? input) + "Return #t if INPUT is a texlive input, #f otherwise." + (match input + (((or "source" (? (cut string-prefix? "texlive-" <>))) . _) #t) + (_ #f))) + +(define (install-as-runfiles dir regexp) + "Install files under DIR matching REGEXP on top of existing runfiles in the +current tree. Sub-directories below DIR are preserved when looking for the +runfile to replace. If a file has no matching runfile, it is ignored." + (let ((runfiles (append-map (cut find-files <>) + (runfiles-root-directories)))) + (for-each (lambda (file) + (match (filter + (cut string-suffix? + (string-drop file (string-length dir)) + <>) + runfiles) + ;; Current file is not a runfile. Ignore it. + (() #f) + ;; One candidate only. Replace it with the one from DIR. + ((destination) + (let ((target (dirname destination))) + (install-file file target) + (format #t "re-generated file ~s in ~s~%" + (basename file) + target))) + ;; Multiple candidates! Not much can be done. Hopefully, + ;; this should never happen. + (_ + (format (current-error-port) + "warning: ambiguous location for file ~s; ignoring it~%" + (basename file))))) + (find-files dir regexp)))) + +(define* (patch-shell-scripts #:rest _) + "Expand filenames for usual tools in shell scripts." + (when (file-exists? "scripts") + (let* ((commands '("awk" "basename" "cat" "grep" "mkdir" "rm" "sed" "sort" + "uname")) + (command-regexp (format #f + "\\b(~a)\\b" + (string-join commands "|")))) + (substitute* (find-files "scripts" "\\.sh$") + ((command-regexp _ command) + (which command)))))) + +(define* (delete-drv-files #:rest _) + "Delete pre-generated \".drv\" files in order to prevent build failures." + (when (file-exists? "source") + (for-each delete-file (find-files "source" "\\.drv$")))) + +(define* (generate-font-metrics #:key native-inputs inputs #:allow-other-keys) + ;; Decide what Metafont files to build by comparing them to the expected + ;; font metrics base names. Keep only files for which the two base names + ;; do match. + (define (font-metrics root) + (and (file-exists? root) + (map (cut basename <> ".tfm") (find-files root "\\.tfm$")))) + (define (font-files directory metrics) + (if (file-exists? directory) + (delete-duplicates + (filter (lambda (f) + (or (not metrics) + (member (basename f ".mf") metrics))) + (find-files directory "\\.mf$"))) + '())) + ;; Metafont files could be scattered across multiple directories. Treat + ;; each sub-directory as a separate font source. + (define (font-sources root metrics) + (delete-duplicates (map dirname (font-files root metrics)))) + (and-let* ((local-metrics (font-metrics "fonts/tfm")) + (local-sources (font-sources "fonts/source" local-metrics)) + ((not (null? local-sources))) ;nothing to generate: bail out + (root (getcwd)) + (metafont + (cond ((assoc-ref (or native-inputs inputs) "texlive-metafont") => + (cut string-append <> "/share/texmf-dist")) + (else + (error "Missing 'texlive-metafont' native input")))) + ;; Collect all font source files from texlive (native-)inputs so + ;; "mf" can know where to look for them. + (font-inputs + (delete-duplicates + (append-map (match-lambda + ((? (negate texlive-input?)) '()) + (("texlive-bin" . _) '()) + (("texlive-metafont" . _) + (list (string-append metafont "/metafont/base"))) + ((_ . input) + (font-sources input #f))) + (or native-inputs inputs))))) + ;; Tell mf where to find "mf.base". + (setenv "MFBASES" (string-append metafont "/web2c/")) + (mkdir-p "build") + (for-each + (lambda (source) + ;; Tell "mf" where are the font source files. In case current package + ;; provides multiple sources, treat them separately. + (setenv "MFINPUTS" + (string-join (cons (string-append root "/" source) + font-inputs) + ":")) + ;; Build font metrics (tfm). + (with-directory-excursion source + (for-each (lambda (font) + (format #t "building font ~a~%" font) + (invoke "mf" "-progname=mf" + (string-append "-output-directory=" + root "/build") + (string-append "\\" + "mode:=ljfour; " + "mag:=1; " + "batchmode; " + "input " + (basename font ".mf")))) + (font-files "." local-metrics))) + ;; Refresh font metrics at the appropriate location. + (install-as-runfiles "build" "\\.tfm$")) + local-sources))) + +(define* (create-formats #:key create-formats inputs #:allow-other-keys) + (define (collect-locations inputs pred) + (delete-duplicates + (append-map (match-lambda + ((? (negate texlive-input?)) '()) + ((_ . dir) + (if pred + (map dirname (find-files dir pred)) + (list dir)))) + inputs))) + (when create-formats + (setenv "TFMFONTS" + (string-join (collect-locations inputs "\\.tfm$") ":")) + (setenv "TEXINPUTS" + (string-join (collect-locations inputs #f) "//:" 'suffix)) + (setenv "LUAINPUTS" + (string-join (collect-locations inputs "\\.lua$") ":")) + (mkdir-p "web2c") + (for-each (cut invoke "fmtutil-sys" "--byfmt" <> "--fmtdir=web2c") + create-formats) + ;; Remove cruft. + (for-each delete-file (find-files "web2c" "\\.log$")))) + +(define (compile-with-latex engine format output file) (invoke engine "-interaction=nonstopmode" - "-output-directory=build" + (string-append "-output-directory=" output) (if format (string-append "&" format) "-ini") file)) (define* (build #:key inputs build-targets tex-engine tex-format #:allow-other-keys) - (mkdir "build") - (for-each (cut compile-with-latex tex-engine tex-format <>) - (if build-targets build-targets - (scandir "." (cut string-suffix? ".ins" <>))))) - -(define* (install #:key outputs tex-directory #:allow-other-keys) - (let* ((out (assoc-ref outputs "out")) - (target (string-append - out "/share/texmf-dist/tex/" tex-directory))) - (mkdir-p target) - (for-each delete-file (find-files "." "\\.(log|aux)$")) - (for-each (cut install-file <> target) - (find-files "build" ".*")))) + (let ((targets + (cond + (build-targets + ;; Collect the relative file names of all the specified targets. + (append-map (lambda (target) + (find-files "source" + (lambda (f _) + (string-suffix? (string-append "/" target) + f)))) + build-targets)) + ((directory-exists? "source") + ;; Prioritize ".ins" files over ".dtx" files. There's no + ;; scientific reasoning here; it just seems to work better. + (match (find-files "source" "\\.ins$") + (() (find-files "source" "\\.dtx$")) + (files files))) + (else '())))) + (unless (null? targets) + (let ((output (string-append (getcwd) "/build"))) + (mkdir-p output) + (for-each (lambda (target) + (with-directory-excursion (dirname target) + (compile-with-latex tex-engine + tex-format + output + (basename target)))) + targets)) + ;; Now move generated files from the "build" directory into the rest of + ;; the source tree, effectively replacing downloaded files. + ;; + ;; Documentation may have been generated, but replace only runfiles, + ;; i.e., files that belong neither to "doc" nor "source" trees. + ;; + ;; In TeX Live, all packages are fully pre-generated. As a consequence, + ;; a generated file from the "build" top directory absent from the rest of + ;; the tree is deemed unnecessary and can safely be ignored. + (install-as-runfiles "build" ".")))) + +(define* (install #:key outputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out")) + (doc (assoc-ref outputs "doc"))) + ;; Take care of documentation. + (when (directory-exists? "doc") + (unless doc + (format (current-error-port) + "warning: missing 'doc' output for package documentation~%")) + (let ((doc-dir (string-append (or doc out) "/share/texmf-dist/doc"))) + (mkdir-p doc-dir) + (copy-recursively "doc" doc-dir))) + ;; Install runfiles. The package may not contain any, though. Create + ;; #$output anyway to handle this situation gracefully. + (mkdir-p out) + (let ((texmf (string-append out "/share/texmf-dist"))) + (for-each (lambda (root) + (let ((destination (string-append texmf "/" root))) + (mkdir-p destination) + (copy-recursively root destination))) + (runfiles-root-directories))))) + +(define* (link-scripts #:key link-scripts outputs #:allow-other-keys) + (when (pair? link-scripts) + (unless (file-exists? "scripts") + (error "missing \"scripts\" directory: no script to link")) + (let ((bin (string-append (assoc-ref outputs "out") "/bin")) + (filenames + (filter (lambda (f) (any (cut string-suffix? <> f) link-scripts)) + (find-files "scripts")))) + ;; Sanity check: make sure no provided script is ignored. + (let ((unknown (lset-difference string=? + (map basename link-scripts) + (map basename filenames)))) + (when (pair? unknown) + (error (format #f "cannot find script(s): ~a~%" + (string-join unknown))))) + ;; All lights are green. Create "bin/" and the symlinks. + (mkdir-p bin) + (for-each + (lambda (script) + ;; Remove extension, if any. + (let ((name (match (string-split (basename script) #\.) + ((name) name) + (tokens (string-join (drop-right tokens 1))))) + (origin (string-append "../share/texmf-dist/" script))) + (format #t "linking bin/~s to ~s~%" name origin) + (symlink origin (string-append bin "/" name)))) + filenames)))) (define %standard-phases (modify-phases gnu:%standard-phases (delete 'bootstrap) (delete 'configure) + (add-after 'unpack 'patch-shell-scripts patch-shell-scripts) + (add-before 'build 'delete-drv-files delete-drv-files) + (add-after 'delete-drv-files 'generate-font-metrics generate-font-metrics) (replace 'build build) + (add-after 'build 'create-formats create-formats) (delete 'check) - (replace 'install install))) + (replace 'install install) + (add-after 'install 'link-scripts link-scripts))) (define* (texlive-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) |