guix/build/gnu-build-system.scm

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