guix/build/gnu-build-system.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix build gnu-build-system)
  22   #:use-module (guix build utils)
  23   #:use-module (guix build gremlin)
  24   #:use-module (guix elf)
  25   #:use-module (ice-9 ftw)
  26   #:use-module (ice-9 match)
  27   #:use-module (ice-9 regex)
  28   #:use-module (ice-9 format)
  29   #:use-module (ice-9 ftw)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-19)
  32   #:use-module (srfi srfi-34)
  33   #:use-module (srfi srfi-35)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (rnrs io ports)
  36   #:export (%standard-phases
  37             %license-file-regexp
  38             dump-file-contents
  39             gnu-build))
  40
  41 ;; Commentary:
  42 ;;
  43 ;; Standard build procedure for packages using the GNU Build System or
  44 ;; something compatible ("./configure && make && make install").  This is the
  45 ;; builder-side code.
  46 ;;
  47 ;; Code:
  48
  49 (cond-expand
  50   (guile-2.2
  51    ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
  52    ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
  53    (define time-monotonic time-tai))
  54   (else #t))
  55
  56 (define* (set-SOURCE-DATE-EPOCH #:rest _)
  57   "Set the 'SOURCE_DATE_EPOCH' environment variable.  This is used by tools
  58 that incorporate timestamps as a way to tell them to use a fixed timestamp.
  59 See https://reproducible-builds.org/specs/source-date-epoch/."
  60   (setenv "SOURCE_DATE_EPOCH" "1")
  61   #t)
  62
  63 (define (first-subdirectory directory)
  64   "Return the file name of the first sub-directory of DIRECTORY."
  65   (match (scandir directory
  66                   (lambda (file)
  67                     (and (not (member file '("." "..")))
  68                          (file-is-directory? (string-append directory "/"
  69                                                             file)))))
  70     ((first . _) first)))
  71
  72 (define* (set-paths #:key target inputs native-inputs
  73                     (search-paths '()) (native-search-paths '())
  74                     #:allow-other-keys)
  75   (define input-directories
  76     (match inputs
  77       (((_ . dir) ...)
  78        dir)))
  79
  80   (define native-input-directories
  81     (match native-inputs
  82       (((_ . dir) ...)
  83        dir)
  84       (#f                                         ; not cross compiling
  85        '())))
  86
  87   ;; Tell 'ld-wrapper' to disallow non-store libraries.
  88   (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no")
  89
  90   ;; When cross building, $PATH must refer only to native (host) inputs since
  91   ;; target inputs are not executable.
  92   (set-path-environment-variable "PATH" '("bin" "sbin")
  93                                  (append native-input-directories
  94                                          (if target
  95                                              '()
  96                                              input-directories)))
  97
  98   (for-each (match-lambda
  99              ((env-var (files ...) separator type pattern)
 100               (set-path-environment-variable env-var files
 101                                              input-directories
 102                                              #:separator separator
 103                                              #:type type
 104                                              #:pattern pattern)))
 105             search-paths)
 106
 107   (when native-search-paths
 108     ;; Search paths for native inputs, when cross building.
 109     (for-each (match-lambda
 110                ((env-var (files ...) separator type pattern)
 111                 (set-path-environment-variable env-var files
 112                                                native-input-directories
 113                                                #:separator separator
 114                                                #:type type
 115                                                #:pattern pattern)))
 116               native-search-paths))
 117
 118   #t)
 119
 120 (define* (install-locale #:key
 121                          (locale "en_US.utf8")
 122                          (locale-category LC_ALL)
 123                          #:allow-other-keys)
 124   "Try to install LOCALE; emit a warning if that fails.  The main goal is to
 125 use a UTF-8 locale so that Guile correctly interprets UTF-8 file names.
 126
 127 This phase must typically happen after 'set-paths' so that $LOCPATH has a
 128 chance to be set."
 129   (catch 'system-error
 130     (lambda ()
 131       (setlocale locale-category locale)
 132
 133       ;; While we're at it, pass it to sub-processes.
 134       (setenv (locale-category->string locale-category) locale)
 135
 136       (format (current-error-port) "using '~a' locale for category ~s~%"
 137               locale (locale-category->string locale-category))
 138       #t)
 139     (lambda args
 140       ;; This is known to fail for instance in early bootstrap where locales
 141       ;; are not available.
 142       (format (current-error-port)
 143               "warning: failed to install '~a' locale: ~a~%"
 144               locale (strerror (system-error-errno args)))
 145       #t)))
 146
 147 (define* (unpack #:key source #:allow-other-keys)
 148   "Unpack SOURCE in the working directory, and change directory within the
 149 source.  When SOURCE is a directory, copy it in a sub-directory of the current
 150 working directory."
 151   (if (file-is-directory? source)
 152       (begin
 153         (mkdir "source")
 154         (chdir "source")
 155
 156         ;; Preserve timestamps (set to the Epoch) on the copied tree so that
 157         ;; things work deterministically.
 158         (copy-recursively source "."
 159                           #:keep-mtime? #t))
 160       (begin
 161         (if (string-suffix? ".zip" source)
 162             (invoke "unzip" source)
 163             (invoke "tar" "xvf" source))
 164         (chdir (first-subdirectory "."))))
 165   #t)
 166
 167 (define %bootstrap-scripts
 168   ;; Typical names of Autotools "bootstrap" scripts.
 169   '("bootstrap" "bootstrap.sh" "autogen.sh"))
 170
 171 (define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts)
 172                     #:allow-other-keys)
 173   "If the code uses Autotools and \"configure\" is missing, run
 174 \"autoreconf\".  Otherwise do nothing."
 175   ;; Note: Run that right after 'unpack' so that the generated files are
 176   ;; visible when the 'patch-source-shebangs' phase runs.
 177   (define (script-exists? file)
 178     (and (file-exists? file)
 179          (not (file-is-directory? file))))
 180
 181   (if (not (script-exists? "configure"))
 182
 183       ;; First try one of the BOOTSTRAP-SCRIPTS.  If none exists, and it's
 184       ;; clearly an Autoconf-based project, run 'autoreconf'.  Otherwise, do
 185       ;; nothing (perhaps the user removed or overrode the 'configure' phase.)
 186       (let ((script (find script-exists? bootstrap-scripts)))
 187         ;; GNU packages often invoke the 'git-version-gen' script from
 188         ;; 'configure.ac' so make sure it has a valid shebang.
 189         (false-if-file-not-found
 190          (patch-shebang "build-aux/git-version-gen"))
 191
 192         (if script
 193             (let ((script (string-append "./" script)))
 194               (setenv "NOCONFIGURE" "true")
 195               (format #t "running '~a'~%" script)
 196               (if (executable-file? script)
 197                   (begin
 198                     (patch-shebang script)
 199                     (invoke script))
 200                   (invoke "sh" script))
 201               ;; Let's clean up after ourselves.
 202               (unsetenv "NOCONFIGURE"))
 203             (if (or (file-exists? "configure.ac")
 204                     (file-exists? "configure.in"))
 205                 (invoke "autoreconf" "-vif")
 206                 (format #t "no 'configure.ac' or anything like that, \
 207 doing nothing~%"))))
 208       (format #t "GNU build system bootstrapping not needed~%"))
 209   #t)
 210
 211 ;; See <http://bugs.gnu.org/17840>.
 212 (define* (patch-usr-bin-file #:key native-inputs inputs
 213                              (patch-/usr/bin/file? #t)
 214                              #:allow-other-keys)
 215   "Patch occurrences of \"/usr/bin/file\" in all the executable 'configure'
 216 files found in the source tree.  This works around Libtool's Autoconf macros,
 217 which generates invocations of \"/usr/bin/file\" that are used to determine
 218 things like the ABI being used."
 219   (when patch-/usr/bin/file?
 220     (for-each (lambda (file)
 221                 (when (executable-file? file)
 222                   (patch-/usr/bin/file file)))
 223               (find-files "." "^configure$")))
 224   #t)
 225
 226 (define* (patch-source-shebangs #:key source #:allow-other-keys)
 227   "Patch shebangs in all source files; this includes non-executable
 228 files such as `.in' templates.  Most scripts honor $SHELL and
 229 $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
 230 `missing' script."
 231   (for-each patch-shebang
 232             (find-files "."
 233                         (lambda (file stat)
 234                           ;; Filter out symlinks.
 235                           (eq? 'regular (stat:type stat)))
 236                         #:stat lstat))
 237   #t)
 238
 239 (define (patch-generated-file-shebangs . rest)
 240   "Patch shebangs in generated files, including `SHELL' variables in
 241 makefiles."
 242   ;; Patch executable regular files, some of which might have been generated
 243   ;; by `configure'.
 244   (for-each patch-shebang
 245             (find-files "."
 246                         (lambda (file stat)
 247                           (and (eq? 'regular (stat:type stat))
 248                                (not (zero? (logand (stat:mode stat) #o100)))))
 249                         #:stat lstat))
 250
 251   ;; Patch `SHELL' in generated makefiles.
 252   (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))
 253
 254   #t)
 255
 256 (define* (configure #:key build target native-inputs inputs outputs
 257                     (configure-flags '()) out-of-source?
 258                     #:allow-other-keys)
 259   (define (package-name)
 260     (let* ((out  (assoc-ref outputs "out"))
 261            (base (basename out))
 262            (dash (string-rindex base #\-)))
 263       ;; XXX: We'd rather use `package-name->name+version' or similar.
 264       (string-drop (if dash
 265                        (substring base 0 dash)
 266                        base)
 267                    (+ 1 (string-index base #\-)))))
 268
 269   (let* ((prefix     (assoc-ref outputs "out"))
 270          (bindir     (assoc-ref outputs "bin"))
 271          (libdir     (assoc-ref outputs "lib"))
 272          (includedir (assoc-ref outputs "include"))
 273          (docdir     (assoc-ref outputs "doc"))
 274          (bash       (or (and=> (assoc-ref (or native-inputs inputs) "bash")
 275                                 (cut string-append <> "/bin/bash"))
 276                          "/bin/sh"))
 277          (flags      `(,@(if target             ; cross building
 278                              '("CC_FOR_BUILD=gcc")
 279                              '())
 280                        ,(string-append "CONFIG_SHELL=" bash)
 281                        ,(string-append "SHELL=" bash)
 282                        ,(string-append "--prefix=" prefix)
 283                        "--enable-fast-install"    ; when using Libtool
 284
 285                        ;; Produce multiple outputs when specific output names
 286                        ;; are recognized.
 287                        ,@(if bindir
 288                               (list (string-append "--bindir=" bindir "/bin"))
 289                               '())
 290                        ,@(if libdir
 291                               (cons (string-append "--libdir=" libdir "/lib")
 292                                     (if includedir
 293                                         '()
 294                                         (list
 295                                          (string-append "--includedir="
 296                                                         libdir "/include"))))
 297                               '())
 298                        ,@(if includedir
 299                              (list (string-append "--includedir="
 300                                                   includedir "/include"))
 301                              '())
 302                        ,@(if docdir
 303                              (list (string-append "--docdir=" docdir
 304                                                   "/share/doc/" (package-name)))
 305                              '())
 306                        ,@(if build
 307                              (list (string-append "--build=" build))
 308                              '())
 309                        ,@(if target               ; cross building
 310                              (list (string-append "--host=" target))
 311                              '())
 312                        ,@configure-flags))
 313          (abs-srcdir (getcwd))
 314          (srcdir     (if out-of-source?
 315                          (string-append "../" (basename abs-srcdir))
 316                          ".")))
 317     (format #t "source directory: ~s (relative from build: ~s)~%"
 318             abs-srcdir srcdir)
 319     (if out-of-source?
 320         (begin
 321           (mkdir "../build")
 322           (chdir "../build")))
 323     (format #t "build directory: ~s~%" (getcwd))
 324     (format #t "configure flags: ~s~%" flags)
 325
 326     ;; Use BASH to reduce reliance on /bin/sh since it may not always be
 327     ;; reliable (see
 328     ;; <http://thread.gmane.org/gmane.linux.distributions.nixos/9748>
 329     ;; for a summary of the situation.)
 330     ;;
 331     ;; Call `configure' with a relative path.  Otherwise, GCC's build system
 332     ;; (for instance) records absolute source file names, which typically
 333     ;; contain the hash part of the `.drv' file, leading to a reference leak.
 334     (apply invoke bash
 335            (string-append srcdir "/configure")
 336            flags)))
 337
 338 (define* (build #:key (make-flags '()) (parallel-build? #t)
 339                 #:allow-other-keys)
 340   (apply invoke "make"
 341          `(,@(if parallel-build?
 342                  `("-j" ,(number->string (parallel-job-count)))
 343                  '())
 344            ,@make-flags)))
 345
 346 (define* (dump-file-contents directory file-regexp
 347                              #:optional (port (current-error-port)))
 348   "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP."
 349   (define (dump file)
 350     (let ((prefix (string-append "\n--- " file " ")))
 351       (display (if (< (string-length prefix) 78)
 352                    (string-pad-right prefix 78 #\-)
 353                    prefix)
 354                port)
 355       (display "\n\n" port)
 356       (call-with-input-file file
 357         (lambda (log)
 358           (dump-port log port)))
 359       (display "\n" port)))
 360
 361   (for-each dump (find-files directory file-regexp)))
 362
 363 (define %test-suite-log-regexp
 364   ;; Name of test suite log files as commonly found in GNU-based build systems
 365   ;; and CMake.
 366   "^(test-?suite\\.log|LastTestFailed\\.log)$")
 367
 368 (define* (check #:key target (make-flags '()) (tests? (not target))
 369                 (test-target "check") (parallel-tests? #t)
 370                 (test-suite-log-regexp %test-suite-log-regexp)
 371                 #:allow-other-keys)
 372   (if tests?
 373       (guard (c ((invoke-error? c)
 374                  ;; Dump the test suite log to facilitate debugging.
 375                  (display "\nTest suite failed, dumping logs.\n"
 376                           (current-error-port))
 377                  (dump-file-contents "." test-suite-log-regexp)
 378                  (raise c)))
 379         (apply invoke "make" test-target
 380                `(,@(if parallel-tests?
 381                        `("-j" ,(number->string (parallel-job-count)))
 382                        '())
 383                  ,@make-flags)))
 384       (format #t "test suite not run~%"))
 385   #t)
 386
 387 (define* (install #:key (make-flags '()) #:allow-other-keys)
 388   (apply invoke "make" "install" make-flags))
 389
 390 (define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t)
 391                          #:allow-other-keys)
 392   (define (list-of-files dir)
 393     (map (cut string-append dir "/" <>)
 394          (or (scandir dir (lambda (f)
 395                             (let ((s (lstat (string-append dir "/" f))))
 396                               (eq? 'regular (stat:type s)))))
 397              '())))
 398
 399   (define bin-directories
 400     (match-lambda
 401      ((_ . dir)
 402       (list (string-append dir "/bin")
 403             (string-append dir "/sbin")))))
 404
 405   (define output-bindirs
 406     (append-map bin-directories outputs))
 407
 408   (define input-bindirs
 409     ;; Shebangs should refer to binaries of the target system---i.e., from
 410     ;; "inputs", not from "native-inputs".
 411     (append-map bin-directories inputs))
 412
 413   (when patch-shebangs?
 414     (let ((path (append output-bindirs input-bindirs)))
 415       (for-each (lambda (dir)
 416                   (let ((files (list-of-files dir)))
 417                     (for-each (cut patch-shebang <> path) files)))
 418                 output-bindirs)))
 419   #t)
 420
 421 (define* (strip #:key target outputs (strip-binaries? #t)
 422                 (strip-command (if target
 423                                    (string-append target "-strip")
 424                                    "strip"))
 425                 (objcopy-command (if target
 426                                      (string-append target "-objcopy")
 427                                      "objcopy"))
 428                 (strip-flags '("--strip-debug"
 429                                "--enable-deterministic-archives"))
 430                 (strip-directories '("lib" "lib64" "libexec"
 431                                      "bin" "sbin"))
 432                 #:allow-other-keys)
 433   (define debug-output
 434     ;; If an output is called "debug", then that's where debugging information
 435     ;; will be stored instead of being discarded.
 436     (assoc-ref outputs "debug"))
 437
 438   (define debug-file-extension
 439     ;; File name extension for debugging information.
 440     ".debug")
 441
 442   (define (debug-file file)
 443     ;; Return the name of the debug file for FILE, an absolute file name.
 444     ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE,
 445     ;; which is where GDB looks for it (info "(gdb) Separate Debug Files").
 446     (string-append debug-output "/lib/debug/"
 447                    file debug-file-extension))
 448
 449   (define (make-debug-file file)
 450     ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE.
 451     (let ((debug (debug-file file)))
 452       (mkdir-p (dirname debug))
 453       (copy-file file debug)
 454       (invoke strip-command "--only-keep-debug" debug)
 455       (chmod debug #o400)))
 456
 457   (define (add-debug-link file)
 458     ;; Add a debug link in FILE (info "(binutils) strip").
 459
 460     ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug
 461     ;; link around so it can compute a CRC of that file (see the
 462     ;; `bfd_fill_in_gnu_debuglink_section' function.)  No reference to
 463     ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
 464     ;; file.
 465     (invoke objcopy-command "--enable-deterministic-archives"
 466             (string-append "--add-gnu-debuglink="
 467                            (debug-file file))
 468             file))
 469
 470   (define (strip-dir dir)
 471     (format #t "stripping binaries in ~s with ~s and flags ~s~%"
 472             dir strip-command strip-flags)
 473     (when debug-output
 474       (format #t "debugging output written to ~s using ~s~%"
 475               debug-output objcopy-command))
 476
 477     (for-each (lambda (file)
 478                 (when (or (elf-file? file) (ar-file? file))
 479                   ;; If an error occurs while processing a file, issue a
 480                   ;; warning and continue to the next file.
 481                   (guard (c ((invoke-error? c)
 482                              (format (current-error-port)
 483                                      "warning: ~a: program ~s exited\
 484 ~@[ with non-zero exit status ~a~]\
 485 ~@[ terminated by signal ~a~]~%"
 486                                      file
 487                                      (invoke-error-program c)
 488                                      (invoke-error-exit-status c)
 489                                      (invoke-error-term-signal c))))
 490                     (when debug-output
 491                       (make-debug-file file))
 492
 493                     ;; Ensure the file is writable.
 494                     (make-file-writable file)
 495
 496                     (apply invoke strip-command
 497                            (append strip-flags (list file)))
 498
 499                     (when debug-output
 500                       (add-debug-link file)))))
 501               (find-files dir
 502                           (lambda (file stat)
 503                             ;; Ignore symlinks such as:
 504                             ;; libfoo.so -> libfoo.so.0.0.
 505                             (eq? 'regular (stat:type stat)))
 506                           #:stat lstat)))
 507
 508   (when strip-binaries?
 509     (for-each
 510      strip-dir
 511      (append-map (match-lambda
 512                    ((_ . dir)
 513                     (filter-map (lambda (d)
 514                                   (let ((sub (string-append dir "/" d)))
 515                                     (and (directory-exists? sub) sub)))
 516                                 strip-directories)))
 517                  outputs)))
 518   #t)
 519
 520 (define* (validate-runpath #:key
 521                            (validate-runpath? #t)
 522                            (elf-directories '("lib" "lib64" "libexec"
 523                                               "bin" "sbin"))
 524                            outputs #:allow-other-keys)
 525   "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
 526 ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.
 527
 528 Since the ELF parser needs to have a copy of files in memory, better run this
 529 phase after stripping."
 530   (define (sub-directory parent)
 531     (lambda (directory)
 532       (let ((directory (string-append parent "/" directory)))
 533         (and (directory-exists? directory) directory))))
 534
 535   (define (validate directory)
 536     (define (file=? file1 file2)
 537       (let ((st1 (stat file1))
 538             (st2 (stat file2)))
 539         (= (stat:ino st1) (stat:ino st2))))
 540
 541     ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
 542     ;; duplicates.
 543     (let ((files (delete-duplicates (find-files directory (lambda (file stat)
 544                                                             (elf-file? file)))
 545                                     file=?)))
 546       (format (current-error-port)
 547               "validating RUNPATH of ~a binaries in ~s...~%"
 548               (length files) directory)
 549       (every* validate-needed-in-runpath files)))
 550
 551   (if validate-runpath?
 552       (let ((dirs (append-map (match-lambda
 553                                 (("debug" . _)
 554                                  ;; The "debug" output is full of ELF files
 555                                  ;; that are not worth checking.
 556                                  '())
 557                                 ((name . output)
 558                                  (filter-map (sub-directory output)
 559                                              elf-directories)))
 560                               outputs)))
 561         (unless (every* validate dirs)
 562           (error "RUNPATH validation failed")))
 563       (format (current-error-port) "skipping RUNPATH validation~%"))
 564
 565   #t)
 566
 567 (define* (validate-documentation-location #:key outputs
 568                                           #:allow-other-keys)
 569   "Documentation should go to 'share/info' and 'share/man', not just 'info/'
 570 and 'man/'.  This phase moves directories to the right place if needed."
 571   (define (validate-sub-directory output sub-directory)
 572     (let ((directory (string-append output "/" sub-directory)))
 573       (when (directory-exists? directory)
 574         (let ((target (string-append output "/share/" sub-directory)))
 575           (format #t "moving '~a' to '~a'~%" directory target)
 576           (mkdir-p (dirname target))
 577           (rename-file directory target)))))
 578
 579   (define (validate-output output)
 580     (for-each (cut validate-sub-directory output <>)
 581               '("man" "info")))
 582
 583   (match outputs
 584     (((names . directories) ...)
 585      (for-each validate-output directories)))
 586   #t)
 587
 588 (define* (reset-gzip-timestamps #:key outputs #:allow-other-keys)
 589   "Reset embedded timestamps in gzip files found in OUTPUTS."
 590   (define (process-directory directory)
 591     (let ((files (find-files directory
 592                              (lambda (file stat)
 593                                (and (eq? 'regular (stat:type stat))
 594                                     (or (string-suffix? ".gz" file)
 595                                         (string-suffix? ".tgz" file))
 596                                     (gzip-file? file)))
 597                              #:stat lstat)))
 598       (for-each reset-gzip-timestamp files)))
 599
 600   (match outputs
 601     (((names . directories) ...)
 602      (for-each process-directory directories)))
 603   #t)
 604
 605 (define* (compress-documentation #:key outputs
 606                                  (compress-documentation? #t)
 607                                  (documentation-compressor "gzip")
 608                                  (documentation-compressor-flags
 609                                   '("--best" "--no-name"))
 610                                  (compressed-documentation-extension ".gz")
 611                                  #:allow-other-keys)
 612   "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files
 613 found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with
 614 DOCUMENTATION-COMPRESSOR-FLAGS."
 615   (define (retarget-symlink link)
 616     (let ((target (readlink link)))
 617       (delete-file link)
 618       (symlink (string-append target compressed-documentation-extension)
 619                link)))
 620
 621   (define (has-links? file)
 622     ;; Return #t if FILE has hard links.
 623     (> (stat:nlink (lstat file)) 1))
 624
 625   (define (points-to-symlink? symlink)
 626     ;; Return #t if SYMLINK points to another symbolic link.
 627     (let* ((target (readlink symlink))
 628            (target-absolute (if (string-prefix? "/" target)
 629                                 target
 630                                 (string-append (dirname symlink)
 631                                                "/" target))))
 632       (catch 'system-error
 633         (lambda ()
 634           (symbolic-link? target-absolute))
 635         (lambda args
 636           (if (= ENOENT (system-error-errno args))
 637               (begin
 638                 (format (current-error-port)
 639                         "The symbolic link '~a' target is missing: '~a'\n"
 640                         symlink target-absolute)
 641                 #f)
 642               (apply throw args))))))
 643
 644   (define (maybe-compress-directory directory regexp)
 645     (when (directory-exists? directory)
 646       (match (find-files directory regexp)
 647         (()                                     ;nothing to compress
 648          #t)
 649         ((files ...)                            ;one or more files
 650          (format #t
 651                  "compressing documentation in '~a' with ~s and flags ~s~%"
 652                  directory documentation-compressor
 653                  documentation-compressor-flags)
 654          (call-with-values
 655              (lambda ()
 656                (partition symbolic-link? files))
 657            (lambda (symlinks regular-files)
 658              ;; Compress the non-symlink files, and adjust symlinks to refer
 659              ;; to the compressed files.  Leave files that have hard links
 660              ;; unchanged ('gzip' would refuse to compress them anyway.)
 661              ;; Also, do not retarget symbolic links pointing to other
 662              ;; symbolic links, since these are not compressed.
 663              (for-each retarget-symlink
 664                        (filter (lambda (symlink)
 665                                  (and (not (points-to-symlink? symlink))
 666                                       (string-match regexp symlink)))
 667                                symlinks))
 668              (apply invoke documentation-compressor
 669                     (append documentation-compressor-flags
 670                             (remove has-links? regular-files)))))))))
 671
 672   (define (maybe-compress output)
 673     (maybe-compress-directory (string-append output "/share/man")
 674                               "\\.[0-9]+$")
 675     (maybe-compress-directory (string-append output "/share/info")
 676                               "\\.info(-[0-9]+)?$"))
 677
 678   (if compress-documentation?
 679       (match outputs
 680         (((names . directories) ...)
 681          (for-each maybe-compress directories)))
 682       (format #t "not compressing documentation~%"))
 683   #t)
 684
 685 (define* (delete-info-dir-file #:key outputs #:allow-other-keys)
 686   "Delete any 'share/info/dir' file from OUTPUTS."
 687   (for-each (match-lambda
 688           ((output . directory)
 689            (let ((info-dir-file (string-append directory "/share/info/dir")))
 690              (when (file-exists? info-dir-file)
 691                (delete-file info-dir-file)))))
 692             outputs)
 693   #t)
 694
 695
 696 (define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
 697   "Replace any references to executables in '.desktop' files with their
 698 absolute file names."
 699   (define bin-directories
 700     (append-map (match-lambda
 701                   ((_ . directory)
 702                    (list (string-append directory "/bin")
 703                          (string-append directory "/sbin"))))
 704                 outputs))
 705
 706   (define (which program)
 707     (or (search-path bin-directories program)
 708         (begin
 709           (format (current-error-port)
 710                   "warning: '.desktop' file refers to '~a', \
 711 which cannot be found~%"
 712                   program)
 713           program)))
 714
 715   (for-each (match-lambda
 716               ((_ . directory)
 717                (let ((applications (string-append directory
 718                                                   "/share/applications")))
 719                  (when (directory-exists? applications)
 720                    (let ((files (find-files applications "\\.desktop$")))
 721                      (format #t "adjusting ~a '.desktop' files in ~s~%"
 722                              (length files) applications)
 723
 724                      ;; '.desktop' files contain translations and are always
 725                      ;; UTF-8-encoded.
 726                      (with-fluids ((%default-port-encoding "UTF-8"))
 727                        (substitute* files
 728                          (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
 729                           (string-append "Exec=" (which binary) rest))
 730                          (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
 731                           (string-append "TryExec="
 732                                          (which binary) rest)))))))))
 733             outputs)
 734   #t)
 735
 736 (define %license-file-regexp
 737   ;; Regexp matching license files.
 738   "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")
 739
 740 (define* (install-license-files #:key outputs
 741                                 (license-file-regexp %license-file-regexp)
 742                                 out-of-source?
 743                                 #:allow-other-keys)
 744   "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
 745   (define (find-source-directory package)
 746     ;; For an out-of-source build, guess the source directory location
 747     ;; relative to the current directory.  Return #f on failure.
 748     (match (scandir ".."
 749                     (lambda (file)
 750                       (and (not (member file '("." ".." "build")))
 751                            (file-is-directory?
 752                             (string-append "../" file)))))
 753       (()                                         ;hmm, no source
 754        #f)
 755       ((source)                                   ;only one other file
 756        (string-append "../" source))
 757       ((directories ...)                          ;pick the most likely one
 758        ;; This happens for example with libstdc++, which lives within the GCC
 759        ;; source tree.
 760        (any (lambda (directory)
 761               (and (string-prefix? package directory)
 762                    (string-append "../" directory)))
 763             directories))))
 764
 765   (define (copy-to-directories directories sub-directory)
 766     (lambda (file)
 767       (for-each (if (file-is-directory? file)
 768                     (cut copy-recursively file <>)
 769                     (cut install-file file <>))
 770                 (map (cut string-append <> "/" sub-directory)
 771                      directories))))
 772
 773   (let* ((regexp    (make-regexp license-file-regexp))
 774          (out       (or (assoc-ref outputs "out")
 775                         (match outputs
 776                           (((_ . output) _ ...)
 777                            output))))
 778          (package   (strip-store-file-name out))
 779          (outputs   (match outputs
 780                       (((_ . outputs) ...)
 781                        outputs)))
 782          (source    (if out-of-source?
 783                         (find-source-directory
 784                          (package-name->name+version package))
 785                         "."))
 786          (files     (and source
 787                          (scandir source
 788                                   (lambda (file)
 789                                     (regexp-exec regexp file))))))
 790     (if files
 791         (begin
 792           (format #t "installing ~a license files from '~a'~%"
 793                   (length files) source)
 794           (for-each (copy-to-directories outputs
 795                                          (string-append "share/doc/"
 796                                                         package))
 797                     (map (cut string-append source "/" <>) files)))
 798         (format (current-error-port)
 799                 "failed to find license files~%"))
 800     #t))
 801
 802 (define %standard-phases
 803   ;; Standard build phases, as a list of symbol/procedure pairs.
 804   (let-syntax ((phases (syntax-rules ()
 805                          ((_ p ...) `((p . ,p) ...)))))
 806     (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack
 807             bootstrap
 808             patch-usr-bin-file
 809             patch-source-shebangs configure patch-generated-file-shebangs
 810             build check install
 811             patch-shebangs strip
 812             validate-runpath
 813             validate-documentation-location
 814             delete-info-dir-file
 815             patch-dot-desktop-files
 816             install-license-files
 817             reset-gzip-timestamps
 818             compress-documentation)))
 819
 820 \f
 821 (define* (gnu-build #:key (source #f) (outputs #f) (inputs #f)
 822                     (phases %standard-phases)
 823                     #:allow-other-keys
 824                     #:rest args)
 825   "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES
 826 in order.  Return #t if all the PHASES succeeded, #f otherwise."
 827   (define (elapsed-time end start)
 828     (let ((diff (time-difference end start)))
 829       (+ (time-second diff)
 830          (/ (time-nanosecond diff) 1e9))))
 831
 832   (setvbuf (current-output-port) 'line)
 833   (setvbuf (current-error-port) 'line)
 834
 835   ;; Encoding/decoding errors shouldn't be silent.
 836   (fluid-set! %default-port-conversion-strategy 'error)
 837
 838   (guard (c ((invoke-error? c)
 839              (report-invoke-error c)
 840              (exit 1)))
 841     ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
 842     ;; PHASES can pick the keyword arguments it's interested in.
 843     (every (match-lambda
 844              ((name . proc)
 845               (let ((start (current-time time-monotonic)))
 846                 (format #t "starting phase `~a'~%" name)
 847                 (let ((result (apply proc args))
 848                       (end    (current-time time-monotonic)))
 849                   (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
 850                           name result
 851                           (elapsed-time end start))
 852
 853                   ;; Issue a warning unless the result is #t.
 854                   (unless (eqv? result #t)
 855                     (format (current-error-port) "\
 856 ## WARNING: phase `~a' returned `~s'.  Return values other than #t
 857 ## are deprecated.  Please migrate this package so that its phase
 858 ## procedures report errors by raising an exception, and otherwise
 859 ## always return #t.~%"
 860                             name result))
 861
 862                   ;; Dump the environment variables as a shell script, for handy debugging.
 863                   (system "export > $NIX_BUILD_TOP/environment-variables")
 864                   result))))
 865            phases)))