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