code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build emacs-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build emacs-utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            %default-include
            %default-exclude
            emacs-build))

;; Commentary:
;;
;; Builder-side code of the build procedure for ELPA Emacs packages.
;;
;; Code:

;; Directory suffix where we install ELPA packages.  We avoid ".../elpa" as
;; Emacs expects to find the ELPA repository 'archive-contents' file and the
;; archive signature.
(define %legacy-install-suffix "/share/emacs/site-lisp")
(define %install-suffix (string-append %legacy-install-suffix "/guix.d"))

;; These are the default inclusion/exclusion regexps for the install phase.
(define %default-include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$"))
(define %default-exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$"
                           "^[^/]*tests?\\.el$"))

(define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack))

(define (store-file->elisp-source-file file)
  "Convert FILE, a store file name for an Emacs Lisp source file, into a file
name that has been stripped of the hash and version number."
  (let ((suffix ".el"))
    (let-values (((name version)
                  (package-name->name+version
                   (basename
                    (strip-store-file-name file) suffix))))
      (string-append name suffix))))

(define* (unpack #:key source #:allow-other-keys)
  "Unpack SOURCE into the build directory.  SOURCE may be a compressed
archive, a directory, or an Emacs Lisp file."
  (if (string-suffix? ".el" source)
      (begin
        (mkdir "source")
        (chdir "source")
        (copy-file source (store-file->elisp-source-file source))
        #t)
      (gnu:unpack #:source source)))

(define* (set-emacs-load-path #:key source inputs #:allow-other-keys)
  (define (inputs->directories inputs)
    "Extract the directory part from INPUTS."
    (match inputs
      (((names . directories) ...) directories)))

  (define (input-directory->el-directory input-directory)
    "Return the correct Emacs Lisp directory in INPUT-DIRECTORY or #f, if there
is no Emacs Lisp directory."
    (let ((legacy-elisp-directory (string-append input-directory %legacy-install-suffix))
          (guix-elisp-directory
           (string-append
            input-directory %install-suffix "/"
            (store-directory->elpa-name-version input-directory))))
      (cond
       ((file-exists? guix-elisp-directory) guix-elisp-directory)
       ((file-exists? legacy-elisp-directory) legacy-elisp-directory)
       (else #f))))

  (define (input-directories->el-directories input-directories)
    "Return the list of Emacs Lisp directories in INPUT-DIRECTORIES."
    (filter-map input-directory->el-directory input-directories))

  "Set the EMACSLOADPATH environment variable so that dependencies are found."
  (let* ((source-directory (getcwd))
         (input-elisp-directories (input-directories->el-directories
                                   (inputs->directories inputs)))
         (emacs-load-path-value
          (string-join
           (append input-elisp-directories (list source-directory))
           ":" 'suffix)))
    (setenv "EMACSLOADPATH" emacs-load-path-value)
    (format #t "environment variable `EMACSLOADPATH' set to ~a\n"
            emacs-load-path-value)))

(define* (build #:key outputs inputs #:allow-other-keys)
  "Compile .el files."
  (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs"))
         (out (assoc-ref outputs "out"))
         (elpa-name-ver (store-directory->elpa-name-version out))
         (el-dir (string-append out %install-suffix "/" elpa-name-ver)))
    (setenv "SHELL" "sh")
    (parameterize ((%emacs emacs))
      (emacs-byte-compile-directory el-dir))))

(define* (patch-el-files #:key outputs #:allow-other-keys)
  "Substitute the absolute \"/bin/\" directory with the right location in the
store in '.el' files."

  (define (file-contains-nul-char? file)
    (call-with-input-file file
      (lambda (in)
        (let loop ((line (read-line in 'concat)))
          (cond
           ((eof-object? line) #f)
           ((string-index line #\nul) #t)
           (else (loop (read-line in 'concat))))))
      #:binary #t))

  (let* ((out (assoc-ref outputs "out"))
         (elpa-name-ver (store-directory->elpa-name-version out))
         (el-dir (string-append out %install-suffix "/" elpa-name-ver))

         ;; (ice-9 regex) uses libc's regexp routines, which cannot deal with
         ;; strings containing NULs.  Filter out such files.  TODO: Remove
         ;; this workaround when <https://bugs.gnu.org/30116> is fixed.
         (el-files (remove file-contains-nul-char?
                           (find-files (getcwd) "\\.el$"))))
    (define (substitute-program-names)
      (substitute* el-files
        (("\"/bin/([^.]\\S*)\"" _ cmd-name)
         (let ((cmd (which cmd-name)))
           (unless cmd
             (error "patch-el-files: unable to locate " cmd-name))
           (string-append "\"" cmd "\"")))))

    (with-directory-excursion el-dir
      ;; Some old '.el' files (e.g., tex-buf.el in AUCTeX) are still
      ;; ISO-8859-1-encoded.
      (unless (false-if-exception (substitute-program-names))
        (with-fluids ((%default-port-encoding "ISO-8859-1"))
          (substitute-program-names))))
    #t))

(define* (check #:key tests? (test-command '("make" "check"))
                (parallel-tests? #t) #:allow-other-keys)
  "Run the tests by invoking TEST-COMMAND.

When TEST-COMMAND uses make and PARALLEL-TESTS is #t, the tests are run in
parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND."
  (match-let (((test-program . args) test-command))
    (let ((using-make? (string=? test-program "make")))
      (if tests?
          (apply invoke test-program
                 `(,@args
                   ,@(if (and using-make? parallel-tests?)
                         `("-j" ,(number->string (parallel-job-count)))
                         '())))
          (begin
            (format #t "test suite not run~%")
            #t)))))

(define* (install #:key outputs
                  (include %default-include)
                  (exclude %default-exclude)
                  #:allow-other-keys)
  "Install the package contents."

  (define source (getcwd))

  (define* (install-file? file stat #:key verbose?)
    (let* ((stripped-file (string-trim
                           (string-drop file (string-length source)) #\/)))
      (define (match-stripped-file action regex)
        (let ((result (string-match regex stripped-file)))
          (when (and result verbose?)
                (format #t "info: ~A ~A as it matches \"~A\"\n"
                        stripped-file action regex))
          result))

      (when verbose?
            (format #t "info: considering installing ~A\n" stripped-file))

      (and (any (cut match-stripped-file "included" <>) include)
           (not (any (cut match-stripped-file "excluded" <>) exclude)))))

  (let* ((out (assoc-ref outputs "out"))
         (elpa-name-ver (store-directory->elpa-name-version out))
         (target-directory (string-append out %install-suffix "/" elpa-name-ver))
         (files-to-install (find-files source install-file?)))
    (cond
     ((not (null? files-to-install))
      (for-each
       (lambda (file)
         (let* ((stripped-file (string-drop file (string-length source)))
                (target-file (string-append target-directory stripped-file)))
           (format #t "`~a' -> `~a'~%" file target-file)
           (install-file file (dirname target-file))))
       files-to-install)
      #t)
     (else
      (format #t "error: No files found to install.\n")
      (find-files source (lambda (file stat)
                           (install-file? file stat #:verbose? #t)))
      #f))))

(define* (move-doc #:key outputs #:allow-other-keys)
  "Move info files from the ELPA package directory to the info directory."
  (let* ((out (assoc-ref outputs "out"))
         (elpa-name-ver (store-directory->elpa-name-version out))
         (el-dir (string-append out %install-suffix "/" elpa-name-ver))
         (name-ver (strip-store-file-name out))
         (info-dir (string-append out "/share/info/"))
         (info-files (find-files el-dir "\\.info$")))
    (unless (null? info-files)
      (mkdir-p info-dir)
      (with-directory-excursion el-dir
        (when (file-exists? "dir") (delete-file "dir"))
        (for-each (lambda (f)
                    (copy-file f (string-append info-dir "/" (basename f)))
                    (delete-file f))
                  info-files)))
    #t))

(define* (make-autoloads #:key outputs inputs #:allow-other-keys)
  "Generate the autoloads file."
  (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs"))
         (out (assoc-ref outputs "out"))
         (elpa-name-ver (store-directory->elpa-name-version out))
         (elpa-name (package-name->name+version elpa-name-ver))
         (el-dir (string-append out %install-suffix "/" elpa-name-ver)))
    (parameterize ((%emacs emacs))
      (emacs-generate-autoloads elpa-name el-dir))))

(define (emacs-package? name)
  "Check if NAME correspond to the name of an Emacs package."
  (string-prefix? "emacs-" name))

(define (package-name-version->elpa-name-version name-ver)
  "Convert the Guix package NAME-VER to the corresponding ELPA name-version
format.  Essentially drop the prefix used in Guix."
  (if (emacs-package? name-ver)  ; checks for "emacs-" prefix
      (string-drop name-ver (string-length "emacs-"))
      name-ver))

(define (store-directory->elpa-name-version store-dir)
  "Given a store directory STORE-DIR return the part of the basename after the
second hyphen.  This corresponds to 'name-version' as used in ELPA packages."
  ((compose package-name-version->elpa-name-version
            strip-store-file-name)
   store-dir))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'unpack unpack)
    (add-after 'unpack 'set-emacs-load-path set-emacs-load-path)
    (delete 'bootstrap)
    (delete 'configure)
    ;; Move the build phase after install: the .el files are byte compiled
    ;; directly in the store.
    (delete 'build)
    (replace 'check check)
    (replace 'install install)
    (add-after 'install 'build build)
    (add-after 'install 'make-autoloads make-autoloads)
    (add-after 'make-autoloads 'patch-el-files patch-el-files)
    (add-after 'make-autoloads 'move-doc move-doc)))

(define* (emacs-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given Emacs package, applying all of PHASES in order."
  (apply gnu:gnu-build
         #:inputs inputs #:phases phases
         args))

;;; emacs-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build emacs-utils)
  #:use-module (guix build utils)
  #:export (%emacs
            emacs-batch-eval
            emacs-batch-edit-file
            emacs-generate-autoloads
            emacs-byte-compile-directory
            emacs-substitute-sexps
            emacs-substitute-variables))

;;; Commentary:
;;;
;;; Tools to programmatically edit files using Emacs,
;;; e.g. to replace entire s-expressions in elisp files.
;;;
;;; Code:

(define %emacs
  ;; The `emacs' command.
  (make-parameter "emacs"))

(define (emacs-batch-eval expr)
  "Run Emacs in batch mode, and execute the elisp code EXPR."
  (invoke (%emacs) "--quick" "--batch"
          (format #f "--eval=~S" expr)))

(define (emacs-batch-edit-file file expr)
  "Load FILE in Emacs using batch mode, and execute the elisp code EXPR."
  (invoke (%emacs) "--quick" "--batch"
          (string-append "--visit=" file)
          (format #f "--eval=~S" expr)))

(define (emacs-generate-autoloads name directory)
  "Generate autoloads for Emacs package NAME placed in DIRECTORY."
  (let* ((file (string-append directory "/" name "-autoloads.el"))
         (expr `(let ((backup-inhibited t)
                      (generated-autoload-file ,file))
                  (update-directory-autoloads ,directory))))
    (emacs-batch-eval expr)))

(define* (emacs-byte-compile-directory dir)
  "Byte compile all files in DIR and its sub-directories."
  (let ((expr `(progn
                (setq byte-compile-debug t) ; for proper exit status
                (byte-recompile-directory (file-name-as-directory ,dir) 0 1))))
    (emacs-batch-eval expr)))

(define-syntax emacs-substitute-sexps
  (syntax-rules ()
    "Substitute the S-expression immediately following the first occurrence of
LEADING-REGEXP by the string returned by REPLACEMENT in FILE.  For example:

  (emacs-substitute-sexps \"w3m.el\"
    (\"defcustom w3m-command\"
     (string-append w3m \"/bin/w3m\"))
    (\"defvar w3m-image-viewer\"
     (string-append imagemagick \"/bin/display\")))

This replaces the default values of the `w3m-command' and `w3m-image-viewer'
variables declared in `w3m.el' with the results of the `string-append' calls
above.  Note that LEADING-REGEXP uses Emacs regexp syntax."
    ((emacs-substitute-sexps file (leading-regexp replacement) ...)
     (emacs-batch-edit-file file
       `(progn (progn (goto-char (point-min))
                      (re-search-forward ,leading-regexp)
                      (kill-sexp)
                      (insert " ")
                      (insert ,(format #f "~S" replacement)))
               ...
               (basic-save-buffer))))))

(define-syntax emacs-substitute-variables
  (syntax-rules ()
    "Substitute the default value of VARIABLE by the string returned by
REPLACEMENT in FILE.  For example:

  (emacs-substitute-variables \"w3m.el\"
    (\"w3m-command\" (string-append w3m \"/bin/w3m\"))
    (\"w3m-image-viewer\" (string-append imagemagick \"/bin/display\")))

This replaces the default values of the `w3m-command' and `w3m-image-viewer'
variables declared in `w3m.el' with the results of the `string-append' calls
above."
    ((emacs-substitute-variables file (variable replacement) ...)
     (emacs-substitute-sexps file
       ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\>")
        replacement)
       ...))))

;;; emacs-utils.scm ends here

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2017 Alex Griffin <a@ajgrf.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build font-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            font-build))

;; Commentary:
;;
;; Builder-side code of the build procedure for font packages.
;;
;; Code:

(define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack))

(define* (unpack #:key source #:allow-other-keys)
  "Unpack SOURCE into the build directory.  SOURCE may be a compressed
archive, or a font file."
  (if (any (cut string-suffix? <> source)
           (list ".ttf" ".otf"))
      (begin
        (mkdir "source")
        (chdir "source")
        (copy-file source (strip-store-file-name source))
        #t)
      (gnu:unpack #:source source)))

(define* (install #:key outputs #:allow-other-keys)
  "Install the package contents."
  (let* ((out (assoc-ref outputs "out"))
         (source (getcwd))
         (fonts (string-append out "/share/fonts")))
    (for-each (cut install-file <> (string-append fonts "/truetype"))
              (find-files source "\\.(ttf|ttc)$"))
    (for-each (cut install-file <> (string-append fonts "/opentype"))
              (find-files source "\\.(otf|otc)$"))
    #t))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (replace 'unpack unpack)
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'check)
    (delete 'build)
    (replace 'install install)))

(define* (font-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given font package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; font-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build git)
  #:use-module (guix build utils)
  #:export (git-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix git-download).  It allows a
;;; Git repository to be cloned and checked out at a specific commit.
;;;
;;; Code:

(define* (git-fetch url commit directory
                    #:key (git-command "git") recursive?)
  "Fetch COMMIT from URL into DIRECTORY.  COMMIT must be a valid Git commit
identifier.  When RECURSIVE? is true, all the sub-modules of URL are fetched,
recursively.  Return #t on success, #f otherwise."

  ;; Disable TLS certificate verification.  The hash of the checkout is known
  ;; in advance anyway.
  (setenv "GIT_SSL_NO_VERIFY" "true")

  (mkdir-p directory)

  (with-directory-excursion directory
    (invoke git-command "init")
    (invoke git-command "remote" "add" "origin" url)
    (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
        (invoke git-command "checkout" "FETCH_HEAD")
        (begin
          (invoke git-command "fetch" "origin")
          (invoke git-command "checkout" commit)))
    (when recursive?
      ;; Now is the time to fetch sub-modules.
      (unless (zero? (system* git-command "submodule" "update"
                                          "--init" "--recursive"))
        (error "failed to fetch sub-modules" url))

      ;; In sub-modules, '.git' is a flat file, not a directory,
      ;; so we can use 'find-files' here.
      (for-each delete-file-recursively
                (find-files directory "^\\.git$")))

      ;; The contents of '.git' vary as a function of the current
      ;; status of the Git repo.  Since we want a fixed output, this
      ;; directory needs to be taken out.
      (delete-file-recursively ".git")
      #t))

;;; git.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build glib-or-gtk-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            glib-or-gtk-build))

;; Commentary:
;;
;; Builder-side code of the standard glib-or-gtk build procedure.
;;
;; Code:

(define (subdirectory-exists? parent sub-directory)
  (directory-exists? (string-append parent sub-directory)))

(define (directory-included? directory directories-list)
  "Is DIRECTORY included in DIRECTORIES-LIST?"
  (fold (lambda (s p) (or (string-ci=? s directory) p))
        #f directories-list))

;; We do not include $HOME/.guix-profile/gtk-v.0 (v=2 or 3) because we do not
;; want to mix gtk+-2 and gtk+-3 modules.  See
;; https://developer.gnome.org/gtk3/stable/gtk-running.html
(define (gtk-module-directories inputs)
  "Check for the existence of \"libdir/gtk-v.0\" in INPUTS.  Return a list
with all found directories."
  (let* ((version
          (if (string-match "gtk\\+-3"
                            (or (assoc-ref inputs "gtk+")
                                (assoc-ref inputs "source")
                                "gtk+-3")) ; we default to version 3
              "3.0"
              "2.0"))
         (gtk-module
          (lambda (input prev)
            (let* ((in (match input
                         ((_ . dir) dir)
                         (_ "")))
                   (libdir
                    (string-append in "/lib/gtk-" version)))
              (if (and (directory-exists? libdir)
                       (not (directory-included? libdir prev)))
                  (cons libdir prev)
                  prev)))))
    (fold gtk-module '() inputs)))

;; See
;; http://www.freedesktop.org/wiki/DesktopThemeSpec
;; http://freedesktop.org/wiki/Specifications/sound-theme-spec
;; http://freedesktop.org/wiki/Specifications/icon-theme-spec
;;
;; Currently desktop themes are not well supported and do not honor
;; XDG_DATA_DIRS.  One example is evince which only looks for desktop themes
;; in $HOME/.themes (for backward compatibility) and in XDG_DATA_HOME (which
;; defaults to $HOME/.local/share).  One way to handle these applications
;; appears to be by making $HOME/.themes a symlink to
;; $HOME/.guix-profile/share/themes.
(define (data-directories inputs)
  "Check for the existence of \"$datadir/glib-2.0/schemas\" or XDG themes data
in INPUTS.  Return a list with all found directories."
  (define (data-directory input previous)
    (let* ((in (match input
                 ((_ . dir) dir)
                 (_ "")))
           (datadir (string-append in "/share")))
      (if (and (or (subdirectory-exists? datadir "/glib-2.0/schemas")
                   (subdirectory-exists? datadir "/sounds")
                   (subdirectory-exists? datadir "/themes")
                   (subdirectory-exists? datadir "/cursors")
                   (subdirectory-exists? datadir "/wallpapers")
                   (subdirectory-exists? datadir "/icons")
                   (subdirectory-exists? datadir "/mime")) ;shared-mime-info
               (not (directory-included? datadir previous)))
          (cons datadir previous)
          previous)))

  (fold data-directory '() inputs))

;; All GIO modules are expected to be installed in GLib's $libdir/gio/modules
;; directory.  That directory has to include a file called giomodule.cache
;; listing all available modules.  GIO can be made aware of modules in other
;; directories with the help of the environment variable GIO_EXTRA_MODULES.
;; The official GIO documentation states that this environment variable should
;; only be used for testing and not in a production environment.  However, it
;; appears that there is no other way of specifying multiple modules
;; directories (NIXOS also does use this variable). See
;; https://developer.gnome.org/gio/stable/running-gio-apps.html
(define (gio-module-directories inputs)
  "Check for the existence of \"$libdir/gio/modules\" in the INPUTS and
returns a list with all found directories."
  (define (gio-module-directory input previous)
    (let* ((in (match input
                 ((_ . dir) dir)
                 (_ "")))
           (gio-mod-dir (string-append in "/lib/gio/modules")))
      (if (and (directory-exists? gio-mod-dir)
               (not (directory-included? gio-mod-dir previous)))
          (cons gio-mod-dir previous)
          previous)))

  (fold gio-module-directory '() inputs))

(define* (wrap-all-programs #:key inputs outputs
                            (glib-or-gtk-wrap-excluded-outputs '())
                            #:allow-other-keys)
  "Implement phase \"glib-or-gtk-wrap\": look for GSettings schemas and
gtk+-v.0 libraries and create wrappers with suitably set environment variables
if found.

Wrapping is not applied to outputs whose name is listed in
GLIB-OR-GTK-WRAP-EXCLUDED-OUTPUTS.  This is useful when an output is known not
to contain any GLib or GTK+ binaries, and where wrapping would gratuitously
add a dependency of that output on GLib and GTK+."
  (define handle-output
    (match-lambda
     ((output . directory)
      (unless (member output glib-or-gtk-wrap-excluded-outputs)
        (let* ((bindir       (string-append directory "/bin"))
               (libexecdir   (string-append directory "/libexec"))
               (bin-list     (append (find-files bindir ".*")
                                     (find-files libexecdir ".*")))
               (datadirs     (data-directories
                              (alist-cons output directory inputs)))
               (gtk-mod-dirs (gtk-module-directories
                              (alist-cons output directory inputs)))
               (gio-mod-dirs (gio-module-directories
                              (alist-cons output directory inputs)))
               (data-env-var
                (if (not (null? datadirs))
                    `("XDG_DATA_DIRS" ":" prefix ,datadirs)
                    #f))
               (gtk-mod-env-var
                (if (not (null? gtk-mod-dirs))
                    `("GTK_PATH" ":" prefix ,gtk-mod-dirs)
                    #f))
               (gio-mod-env-var
                (if (not (null? gio-mod-dirs))
                    `("GIO_EXTRA_MODULES" ":" prefix ,gio-mod-dirs)
                    #f)))
          (cond
           ((and data-env-var gtk-mod-env-var gio-mod-env-var)
            (for-each (cut wrap-program <>
                           data-env-var
                           gtk-mod-env-var
                           gio-mod-env-var)
                      bin-list))
           ((and data-env-var gtk-mod-env-var (not gio-mod-env-var))
            (for-each (cut wrap-program <>
                           data-env-var
                           gtk-mod-env-var)
                      bin-list))
           ((and data-env-var (not gtk-mod-env-var) gio-mod-env-var)
            (for-each (cut wrap-program <>
                           data-env-var
                           gio-mod-env-var)
                      bin-list))
           ((and (not data-env-var) gtk-mod-env-var gio-mod-env-var)
            (for-each (cut wrap-program <>
                           gio-mod-env-var
                           gtk-mod-env-var)
                      bin-list))
           ((and data-env-var (not gtk-mod-env-var) (not gio-mod-env-var))
            (for-each (cut wrap-program <>
                           data-env-var)
                      bin-list))
           ((and (not data-env-var) gtk-mod-env-var (not gio-mod-env-var))
            (for-each (cut wrap-program <>
                           gtk-mod-env-var)
                      bin-list))
           ((and (not data-env-var) (not gtk-mod-env-var) gio-mod-env-var)
            (for-each (cut wrap-program <>
                           gio-mod-env-var)
                      bin-list))))))))

  (for-each handle-output outputs)
  #t)

(define* (compile-glib-schemas #:key outputs #:allow-other-keys)
  "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas
if needed."
  (for-each (match-lambda
              ((output . directory)
               (let ((schemasdir (string-append directory
                                                "/share/glib-2.0/schemas")))
                 (when (and (directory-exists? schemasdir)
                            (not (file-exists?
                                  (string-append schemasdir "/gschemas.compiled"))))
                   (invoke "glib-compile-schemas" schemasdir)))))
            outputs)
  #t)

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (add-after 'install 'glib-or-gtk-compile-schemas compile-glib-schemas)
    (add-after 'install 'glib-or-gtk-wrap wrap-all-programs)))

(define* (glib-or-gtk-build #:key inputs (phases %standard-phases)
                            #:allow-other-keys #:rest args)
  "Build the given package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

;;; glib-or-gtk-build-system.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build gnu-build-system)
  #:use-module (guix build utils)
  #:use-module (guix build gremlin)
  #:use-module (guix elf)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs io ports)
  #:export (%standard-phases
            %license-file-regexp
            dump-file-contents
            gnu-build))

;; Commentary:
;;
;; Standard build procedure for packages using the GNU Build System or
;; something compatible ("./configure && make && make install").  This is the
;; builder-side code.
;;
;; Code:

(cond-expand
  (guile-2.2
   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
   (define time-monotonic time-tai))
  (else #t))

(define* (set-SOURCE-DATE-EPOCH #:rest _)
  "Set the 'SOURCE_DATE_EPOCH' environment variable.  This is used by tools
that incorporate timestamps as a way to tell them to use a fixed timestamp.
See https://reproducible-builds.org/specs/source-date-epoch/."
  (setenv "SOURCE_DATE_EPOCH" "1")
  #t)

(define (first-subdirectory dir)
  "Return the path of the first sub-directory of DIR."
  (file-system-fold (lambda (path stat result)
                      (string=? path dir))
                    (lambda (path stat result) result) ; leaf
                    (lambda (path stat result) result) ; down
                    (lambda (path stat result) result) ; up
                    (lambda (path stat result)         ; skip
                      (or result path))
                    (lambda (path stat errno result)   ; error
                      (error "first-subdirectory" (strerror errno)))
                    #f
                    dir))

(define* (set-paths #:key target inputs native-inputs
                    (search-paths '()) (native-search-paths '())
                    #:allow-other-keys)
  (define input-directories
    (match inputs
      (((_ . dir) ...)
       dir)))

  (define native-input-directories
    (match native-inputs
      (((_ . dir) ...)
       dir)
      (#f                                         ; not cross compiling
       '())))

  ;; Tell 'ld-wrapper' to disallow non-store libraries.
  (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no")

  ;; When cross building, $PATH must refer only to native (host) inputs since
  ;; target inputs are not executable.
  (set-path-environment-variable "PATH" '("bin" "sbin")
                                 (append native-input-directories
                                         (if target
                                             '()
                                             input-directories)))

  (for-each (match-lambda
             ((env-var (files ...) separator type pattern)
              (set-path-environment-variable env-var files
                                             input-directories
                                             #:separator separator
                                             #:type type
                                             #:pattern pattern)))
            search-paths)

  (when native-search-paths
    ;; Search paths for native inputs, when cross building.
    (for-each (match-lambda
               ((env-var (files ...) separator type pattern)
                (set-path-environment-variable env-var files
                                               native-input-directories
                                               #:separator separator
                                               #:type type
                                               #:pattern pattern)))
              native-search-paths))

  #t)

(define* (install-locale #:key
                         (locale "en_US.utf8")
                         (locale-category LC_ALL)
                         #:allow-other-keys)
  "Try to install LOCALE; emit a warning if that fails.  The main goal is to
use a UTF-8 locale so that Guile correctly interprets UTF-8 file names.

This phase must typically happen after 'set-paths' so that $LOCPATH has a
chance to be set."
  (catch 'system-error
    (lambda ()
      (setlocale locale-category locale)

      ;; While we're at it, pass it to sub-processes.
      (setenv (locale-category->string locale-category) locale)

      (format (current-error-port) "using '~a' locale for category ~s~%"
              locale (locale-category->string locale-category))
      #t)
    (lambda args
      ;; This is known to fail for instance in early bootstrap where locales
      ;; are not available.
      (format (current-error-port)
              "warning: failed to install '~a' locale: ~a~%"
              locale (strerror (system-error-errno args)))
      #t)))

(define* (unpack #:key source #:allow-other-keys)
  "Unpack SOURCE in the working directory, and change directory within the
source.  When SOURCE is a directory, copy it in a sub-directory of the current
working directory."
  (if (file-is-directory? source)
      (begin
        (mkdir "source")
        (chdir "source")

        ;; Preserve timestamps (set to the Epoch) on the copied tree so that
        ;; things work deterministically.
        (copy-recursively source "."
                          #:keep-mtime? #t))
      (begin
        (if (string-suffix? ".zip" source)
            (invoke "unzip" source)
            (invoke "tar" "xvf" source))
        (chdir (first-subdirectory "."))))
  #t)

(define %bootstrap-scripts
  ;; Typical names of Autotools "bootstrap" scripts.
  '("bootstrap" "bootstrap.sh" "autogen.sh"))

(define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts)
                    #:allow-other-keys)
  "If the code uses Autotools and \"configure\" is missing, run
\"autoreconf\".  Otherwise do nothing."
  ;; Note: Run that right after 'unpack' so that the generated files are
  ;; visible when the 'patch-source-shebangs' phase runs.
  (if (not (file-exists? "configure"))

      ;; First try one of the BOOTSTRAP-SCRIPTS.  If none exists, and it's
      ;; clearly an Autoconf-based project, run 'autoreconf'.  Otherwise, do
      ;; nothing (perhaps the user removed or overrode the 'configure' phase.)
      (let ((script (find file-exists? bootstrap-scripts)))
        ;; GNU packages often invoke the 'git-version-gen' script from
        ;; 'configure.ac' so make sure it has a valid shebang.
        (false-if-file-not-found
         (patch-shebang "build-aux/git-version-gen"))

        (if script
            (let ((script (string-append "./" script)))
              (format #t "running '~a'~%" script)
              (if (executable-file? script)
                  (begin
                    (patch-shebang script)
                    (invoke script))
                  (invoke "sh" script)))
            (if (or (file-exists? "configure.ac")
                    (file-exists? "configure.in"))
                (invoke "autoreconf" "-vif")
                (format #t "no 'configure.ac' or anything like that, \
doing nothing~%"))))
      (format #t "GNU build system bootstrapping not needed~%"))
  #t)

;; See <http://bugs.gnu.org/17840>.
(define* (patch-usr-bin-file #:key native-inputs inputs
                             (patch-/usr/bin/file? #t)
                             #:allow-other-keys)
  "Patch occurrences of \"/usr/bin/file\" in all the executable 'configure'
files found in the source tree.  This works around Libtool's Autoconf macros,
which generates invocations of \"/usr/bin/file\" that are used to determine
things like the ABI being used."
  (when patch-/usr/bin/file?
    (for-each (lambda (file)
                (when (executable-file? file)
                  (patch-/usr/bin/file file)))
              (find-files "." "^configure$")))
  #t)

(define* (patch-source-shebangs #:key source #:allow-other-keys)
  "Patch shebangs in all source files; this includes non-executable
files such as `.in' templates.  Most scripts honor $SHELL and
$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
`missing' script."
  (for-each patch-shebang
            (find-files "."
                        (lambda (file stat)
                          ;; Filter out symlinks.
                          (eq? 'regular (stat:type stat)))
                        #:stat lstat))
  #t)

(define (patch-generated-file-shebangs . rest)
  "Patch shebangs in generated files, including `SHELL' variables in
makefiles."
  ;; Patch executable regular files, some of which might have been generated
  ;; by `configure'.
  (for-each patch-shebang
            (find-files "."
                        (lambda (file stat)
                          (and (eq? 'regular (stat:type stat))
                               (not (zero? (logand (stat:mode stat) #o100)))))
                        #:stat lstat))

  ;; Patch `SHELL' in generated makefiles.
  (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))

  #t)

(define* (configure #:key build target native-inputs inputs outputs
                    (configure-flags '()) out-of-source?
                    #:allow-other-keys)
  (define (package-name)
    (let* ((out  (assoc-ref outputs "out"))
           (base (basename out))
           (dash (string-rindex base #\-)))
      ;; XXX: We'd rather use `package-name->name+version' or similar.
      (string-drop (if dash
                       (substring base 0 dash)
                       base)
                   (+ 1 (string-index base #\-)))))

  (let* ((prefix     (assoc-ref outputs "out"))
         (bindir     (assoc-ref outputs "bin"))
         (libdir     (assoc-ref outputs "lib"))
         (includedir (assoc-ref outputs "include"))
         (docdir     (assoc-ref outputs "doc"))
         (bash       (or (and=> (assoc-ref (or native-inputs inputs) "bash")
                                (cut string-append <> "/bin/bash"))
                         "/bin/sh"))
         (flags      `(,@(if target             ; cross building
                             '("CC_FOR_BUILD=gcc")
                             '())
                       ,(string-append "CONFIG_SHELL=" bash)
                       ,(string-append "SHELL=" bash)
                       ,(string-append "--prefix=" prefix)
                       "--enable-fast-install"    ; when using Libtool

                       ;; Produce multiple outputs when specific output names
                       ;; are recognized.
                       ,@(if bindir
                              (list (string-append "--bindir=" bindir "/bin"))
                              '())
                       ,@(if libdir
                              (cons (string-append "--libdir=" libdir "/lib")
                                    (if includedir
                                        '()
                                        (list
                                         (string-append "--includedir="
                                                        libdir "/include"))))
                              '())
                       ,@(if includedir
                             (list (string-append "--includedir="
                                                  includedir "/include"))
                             '())
                       ,@(if docdir
                             (list (string-append "--docdir=" docdir
                                                  "/share/doc/" (package-name)))
                             '())
                       ,@(if build
                             (list (string-append "--build=" build))
                             '())
                       ,@(if target               ; cross building
                             (list (string-append "--host=" target))
                             '())
                       ,@configure-flags))
         (abs-srcdir (getcwd))
         (srcdir     (if out-of-source?
                         (string-append "../" (basename abs-srcdir))
                         ".")))
    (format #t "source directory: ~s (relative from build: ~s)~%"
            abs-srcdir srcdir)
    (if out-of-source?
        (begin
          (mkdir "../build")
          (chdir "../build")))
    (format #t "build directory: ~s~%" (getcwd))
    (format #t "configure flags: ~s~%" flags)

    ;; Use BASH to reduce reliance on /bin/sh since it may not always be
    ;; reliable (see
    ;; <http://thread.gmane.org/gmane.linux.distributions.nixos/9748>
    ;; for a summary of the situation.)
    ;;
    ;; Call `configure' with a relative path.  Otherwise, GCC's build system
    ;; (for instance) records absolute source file names, which typically
    ;; contain the hash part of the `.drv' file, leading to a reference leak.
    (apply invoke bash
           (string-append srcdir "/configure")
           flags)))

(define* (build #:key (make-flags '()) (parallel-build? #t)
                #:allow-other-keys)
  (apply invoke "make"
         `(,@(if parallel-build?
                 `("-j" ,(number->string (parallel-job-count)))
                 '())
           ,@make-flags)))

(define* (dump-file-contents directory file-regexp
                             #:optional (port (current-error-port)))
  "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP."
  (define (dump file)
    (let ((prefix (string-append "\n--- " file " ")))
      (display (if (< (string-length prefix) 78)
                   (string-pad-right prefix 78 #\-)
                   prefix)
               port)
      (display "\n\n" port)
      (call-with-input-file file
        (lambda (log)
          (dump-port log port)))
      (display "\n" port)))

  (for-each dump (find-files directory file-regexp)))

(define %test-suite-log-regexp
  ;; Name of test suite log files as commonly found in GNU-based build systems
  ;; and CMake.
  "^(test-?suite\\.log|LastTestFailed\\.log)$")

(define* (check #:key target (make-flags '()) (tests? (not target))
                (test-target "check") (parallel-tests? #t)
                (test-suite-log-regexp %test-suite-log-regexp)
                #:allow-other-keys)
  (if tests?
      (guard (c ((invoke-error? c)
                 ;; Dump the test suite log to facilitate debugging.
                 (display "\nTest suite failed, dumping logs.\n"
                          (current-error-port))
                 (dump-file-contents "." test-suite-log-regexp)
                 (raise c)))
        (apply invoke "make" test-target
               `(,@(if parallel-tests?
                       `("-j" ,(number->string (parallel-job-count)))
                       '())
                 ,@make-flags)))
      (format #t "test suite not run~%"))
  #t)

(define* (install #:key (make-flags '()) #:allow-other-keys)
  (apply invoke "make" "install" make-flags))

(define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t)
                         #:allow-other-keys)
  (define (list-of-files dir)
    (map (cut string-append dir "/" <>)
         (or (scandir dir (lambda (f)
                            (let ((s (lstat (string-append dir "/" f))))
                              (eq? 'regular (stat:type s)))))
             '())))

  (define bin-directories
    (match-lambda
     ((_ . dir)
      (list (string-append dir "/bin")
            (string-append dir "/sbin")))))

  (define output-bindirs
    (append-map bin-directories outputs))

  (define input-bindirs
    ;; Shebangs should refer to binaries of the target system---i.e., from
    ;; "inputs", not from "native-inputs".
    (append-map bin-directories inputs))

  (when patch-shebangs?
    (let ((path (append output-bindirs input-bindirs)))
      (for-each (lambda (dir)
                  (let ((files (list-of-files dir)))
                    (for-each (cut patch-shebang <> path) files)))
                output-bindirs)))
  #t)

(define* (strip #:key target outputs (strip-binaries? #t)
                (strip-command (if target
                                   (string-append target "-strip")
                                   "strip"))
                (objcopy-command (if target
                                     (string-append target "-objcopy")
                                     "objcopy"))
                (strip-flags '("--strip-debug"
                               "--enable-deterministic-archives"))
                (strip-directories '("lib" "lib64" "libexec"
                                     "bin" "sbin"))
                #:allow-other-keys)
  (define debug-output
    ;; If an output is called "debug", then that's where debugging information
    ;; will be stored instead of being discarded.
    (assoc-ref outputs "debug"))

  (define debug-file-extension
    ;; File name extension for debugging information.
    ".debug")

  (define (debug-file file)
    ;; Return the name of the debug file for FILE, an absolute file name.
    ;; Once installed in the user's profile, it is in $PROFILE/lib/debug/FILE,
    ;; which is where GDB looks for it (info "(gdb) Separate Debug Files").
    (string-append debug-output "/lib/debug/"
                   file debug-file-extension))

  (define (make-debug-file file)
    ;; Create a file in DEBUG-OUTPUT containing the debugging info of FILE.
    (let ((debug (debug-file file)))
      (mkdir-p (dirname debug))
      (copy-file file debug)
      (invoke strip-command "--only-keep-debug" debug)
      (chmod debug #o400)))

  (define (add-debug-link file)
    ;; Add a debug link in FILE (info "(binutils) strip").

    ;; `objcopy --add-gnu-debuglink' wants to have the target of the debug
    ;; link around so it can compute a CRC of that file (see the
    ;; `bfd_fill_in_gnu_debuglink_section' function.)  No reference to
    ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug
    ;; file.
    (invoke objcopy-command "--enable-deterministic-archives"
            (string-append "--add-gnu-debuglink="
                           (debug-file file))
            file))

  (define (strip-dir dir)
    (format #t "stripping binaries in ~s with ~s and flags ~s~%"
            dir strip-command strip-flags)
    (when debug-output
      (format #t "debugging output written to ~s using ~s~%"
              debug-output objcopy-command))

    (for-each (lambda (file)
                (when (or (elf-file? file) (ar-file? file))
                  ;; If an error occurs while processing a file, issue a
                  ;; warning and continue to the next file.
                  (guard (c ((invoke-error? c)
                             (format (current-error-port)
                                     "warning: ~a: program ~s exited\
~@[ with non-zero exit status ~a~]\
~@[ terminated by signal ~a~]~%"
                                     file
                                     (invoke-error-program c)
                                     (invoke-error-exit-status c)
                                     (invoke-error-term-signal c))))
                    (when debug-output
                      (make-debug-file file))

                    ;; Ensure the file is writable.
                    (make-file-writable file)

                    (apply invoke strip-command
                           (append strip-flags (list file)))

                    (when debug-output
                      (add-debug-link file)))))
              (find-files dir
                          (lambda (file stat)
                            ;; Ignore symlinks such as:
                            ;; libfoo.so -> libfoo.so.0.0.
                            (eq? 'regular (stat:type stat)))
                          #:stat lstat)))

  (when strip-binaries?
    (for-each
     strip-dir
     (append-map (match-lambda
                   ((_ . dir)
                    (filter-map (lambda (d)
                                  (let ((sub (string-append dir "/" d)))
                                    (and (directory-exists? sub) sub)))
                                strip-directories)))
                 outputs)))
  #t)

(define* (validate-runpath #:key
                           (validate-runpath? #t)
                           (elf-directories '("lib" "lib64" "libexec"
                                              "bin" "sbin"))
                           outputs #:allow-other-keys)
  "When VALIDATE-RUNPATH? is true, validate that all the ELF files in
ELF-DIRECTORIES have their dependencies found in their 'RUNPATH'.

Since the ELF parser needs to have a copy of files in memory, better run this
phase after stripping."
  (define (sub-directory parent)
    (lambda (directory)
      (let ((directory (string-append parent "/" directory)))
        (and (directory-exists? directory) directory))))

  (define (validate directory)
    (define (file=? file1 file2)
      (let ((st1 (stat file1))
            (st2 (stat file2)))
        (= (stat:ino st1) (stat:ino st2))))

    ;; There are always symlinks from '.so' to '.so.1' and so on, so delete
    ;; duplicates.
    (let ((files (delete-duplicates (find-files directory (lambda (file stat)
                                                            (elf-file? file)))
                                    file=?)))
      (format (current-error-port)
              "validating RUNPATH of ~a binaries in ~s...~%"
              (length files) directory)
      (every* validate-needed-in-runpath files)))

  (if validate-runpath?
      (let ((dirs (append-map (match-lambda
                                (("debug" . _)
                                 ;; The "debug" output is full of ELF files
                                 ;; that are not worth checking.
                                 '())
                                ((name . output)
                                 (filter-map (sub-directory output)
                                             elf-directories)))
                              outputs)))
        (unless (every* validate dirs)
          (error "RUNPATH validation failed")))
      (format (current-error-port) "skipping RUNPATH validation~%"))

  #t)

(define* (validate-documentation-location #:key outputs
                                          #:allow-other-keys)
  "Documentation should go to 'share/info' and 'share/man', not just 'info/'
and 'man/'.  This phase moves directories to the right place if needed."
  (define (validate-sub-directory output sub-directory)
    (let ((directory (string-append output "/" sub-directory)))
      (when (directory-exists? directory)
        (let ((target (string-append output "/share/" sub-directory)))
          (format #t "moving '~a' to '~a'~%" directory target)
          (mkdir-p (dirname target))
          (rename-file directory target)))))

  (define (validate-output output)
    (for-each (cut validate-sub-directory output <>)
              '("man" "info")))

  (match outputs
    (((names . directories) ...)
     (for-each validate-output directories)))
  #t)

(define* (reset-gzip-timestamps #:key outputs #:allow-other-keys)
  "Reset embedded timestamps in gzip files found in OUTPUTS."
  (define (process-directory directory)
    (let ((files (find-files directory
                             (lambda (file stat)
                               (and (eq? 'regular (stat:type stat))
                                    (or (string-suffix? ".gz" file)
                                        (string-suffix? ".tgz" file))
                                    (gzip-file? file)))
                             #:stat lstat)))
      (for-each reset-gzip-timestamp files)))

  (match outputs
    (((names . directories) ...)
     (for-each process-directory directories)))
  #t)

(define* (compress-documentation #:key outputs
                                 (compress-documentation? #t)
                                 (documentation-compressor "gzip")
                                 (documentation-compressor-flags
                                  '("--best" "--no-name"))
                                 (compressed-documentation-extension ".gz")
                                 #:allow-other-keys)
  "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files
found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with
DOCUMENTATION-COMPRESSOR-FLAGS."
  (define (retarget-symlink link)
    (let ((target (readlink link)))
      (delete-file link)
      (symlink (string-append target compressed-documentation-extension)
               link)))

  (define (has-links? file)
    ;; Return #t if FILE has hard links.
    (> (stat:nlink (lstat file)) 1))

  (define (points-to-symlink? symlink)
    ;; Return #t if SYMLINK points to another symbolic link.
    (let* ((target (readlink symlink))
           (target-absolute (if (string-prefix? "/" target)
                                target
                                (string-append (dirname symlink)
                                               "/" target))))
      (catch 'system-error
        (lambda ()
          (symbolic-link? target-absolute))
        (lambda args
          (if (= ENOENT (system-error-errno args))
              (begin
                (format (current-error-port)
                        "The symbolic link '~a' target is missing: '~a'\n"
                        symlink target-absolute)
                #f)
              (apply throw args))))))

  (define (maybe-compress-directory directory regexp)
    (when (directory-exists? directory)
      (match (find-files directory regexp)
        (()                                     ;nothing to compress
         #t)
        ((files ...)                            ;one or more files
         (format #t
                 "compressing documentation in '~a' with ~s and flags ~s~%"
                 directory documentation-compressor
                 documentation-compressor-flags)
         (call-with-values
             (lambda ()
               (partition symbolic-link? files))
           (lambda (symlinks regular-files)
             ;; Compress the non-symlink files, and adjust symlinks to refer
             ;; to the compressed files.  Leave files that have hard links
             ;; unchanged ('gzip' would refuse to compress them anyway.)
             ;; Also, do not retarget symbolic links pointing to other
             ;; symbolic links, since these are not compressed.
             (for-each retarget-symlink
                       (filter (lambda (symlink)
                                 (and (not (points-to-symlink? symlink))
                                      (string-match regexp symlink)))
                               symlinks))
             (apply invoke documentation-compressor
                    (append documentation-compressor-flags
                            (remove has-links? regular-files)))))))))

  (define (maybe-compress output)
    (maybe-compress-directory (string-append output "/share/man")
                              "\\.[0-9]+$")
    (maybe-compress-directory (string-append output "/share/info")
                              "\\.info(-[0-9]+)?$"))

  (if compress-documentation?
      (match outputs
        (((names . directories) ...)
         (for-each maybe-compress directories)))
      (format #t "not compressing documentation~%"))
  #t)

(define* (delete-info-dir-file #:key outputs #:allow-other-keys)
  "Delete any 'share/info/dir' file from OUTPUTS."
  (for-each (match-lambda
          ((output . directory)
           (let ((info-dir-file (string-append directory "/share/info/dir")))
             (when (file-exists? info-dir-file)
               (delete-file info-dir-file)))))
            outputs)
  #t)

(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
  "Replace any references to executables in '.desktop' files with their
absolute file names."
  (define bin-directories
    (append-map (match-lambda
                  ((_ . directory)
                   (list (string-append directory "/bin")
                         (string-append directory "/sbin"))))
                outputs))

  (define (which program)
    (or (search-path bin-directories program)
        (begin
          (format (current-error-port)
                  "warning: '.desktop' file refers to '~a', \
which cannot be found~%"
                  program)
          program)))

  (for-each (match-lambda
              ((_ . directory)
               (let ((applications (string-append directory
                                                  "/share/applications")))
                 (when (directory-exists? applications)
                   (let ((files (find-files applications "\\.desktop$")))
                     (format #t "adjusting ~a '.desktop' files in ~s~%"
                             (length files) applications)

                     ;; '.desktop' files contain translations and are always
                     ;; UTF-8-encoded.
                     (with-fluids ((%default-port-encoding "UTF-8"))
                       (substitute* files
                         (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
                          (string-append "Exec=" (which binary) rest))
                         (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
                          (string-append "TryExec="
                                         (which binary) rest)))))))))
            outputs)
  #t)

(define %license-file-regexp
  ;; Regexp matching license files.
  "^(COPYING.*|LICEN[CS]E.*|[Ll]icen[cs]e.*|Copy[Rr]ight(\\.(txt|md))?)$")

(define* (install-license-files #:key outputs
                                (license-file-regexp %license-file-regexp)
                                #:allow-other-keys)
  "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
  (let* ((regexp    (make-regexp license-file-regexp))
         (out       (or (assoc-ref outputs "out")
                        (match outputs
                          (((_ . output) _ ...)
                           output))))
         (package   (strip-store-file-name out))
         (directory (string-append out "/share/doc/" package))
         (files     (scandir "." (lambda (file)
                                   (regexp-exec regexp file)))))
    (format #t "installing ~a license files~%" (length files))
    (for-each (lambda (file)
                (if (file-is-directory? file)
                    (copy-recursively file directory)
                    (install-file file directory)))
              files)
    #t))

(define %standard-phases
  ;; Standard build phases, as a list of symbol/procedure pairs.
  (let-syntax ((phases (syntax-rules ()
                         ((_ p ...) `((p . ,p) ...)))))
    (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack
            bootstrap
            patch-usr-bin-file
            patch-source-shebangs configure patch-generated-file-shebangs
            build check install
            patch-shebangs strip
            validate-runpath
            validate-documentation-location
            delete-info-dir-file
            patch-dot-desktop-files
            install-license-files
            reset-gzip-timestamps
            compress-documentation)))

(define* (gnu-build #:key (source #f) (outputs #f) (inputs #f)
                    (phases %standard-phases)
                    #:allow-other-keys
                    #:rest args)
  "Build from SOURCE to OUTPUTS, using INPUTS, and by running all of PHASES
in order.  Return #t if all the PHASES succeeded, #f otherwise."
  (define (elapsed-time end start)
    (let ((diff (time-difference end start)))
      (+ (time-second diff)
         (/ (time-nanosecond diff) 1e9))))

  (setvbuf (current-output-port) _IOLBF)
  (setvbuf (current-error-port) _IOLBF)

  ;; Encoding/decoding errors shouldn't be silent.
  (fluid-set! %default-port-conversion-strategy 'error)

  ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
  ;; PHASES can pick the keyword arguments it's interested in.
  (for-each (match-lambda
              ((name . proc)
               (let ((start (current-time time-monotonic)))
                 (format #t "starting phase `~a'~%" name)
                 (let ((result (apply proc args))
                       (end    (current-time time-monotonic)))
                   (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
                           name result
                           (elapsed-time end start))

                   ;; Issue a warning unless the result is #t.
                   (unless (eqv? result #t)
                     (format (current-error-port) "\
## WARNING: phase `~a' returned `~s'.  Return values other than #t
## are deprecated.  Please migrate this package so that its phase
## procedures report errors by raising an exception, and otherwise
## always return #t.~%"
                             name result))

                   ;; Dump the environment variables as a shell script, for handy debugging.
                   (system "export > $NIX_BUILD_TOP/environment-variables")
                   result))))
            phases))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build gnu-dist)
  #:use-module (guix build utils)
  #:use-module (guix build gnu-build-system)
  #:use-module (srfi srfi-1)
  #:export (%dist-phases))

;;; Commentary:
;;;
;;; Build phases to build a source tarball with the GNU build system, as with
;;; "make distcheck".
;;;
;;; Code:

(define* (copy-source #:key source #:allow-other-keys)
  (copy-recursively source "."))

(define* (autoreconf #:rest args)
  (letrec-syntax ((try-files (syntax-rules (else)
                               ((_ (else fallback ...))
                                (begin fallback ...))
                               ((_ file files ... (else fallback ...))
                                (if (file-exists? file)
                                    (begin
                                      (format #t "bootstrapping with `~a'...~%"
                                              file)
                                      (invoke (string-append "./" file)))
                                    (try-files files ...
                                               (else fallback ...)))))))
    (try-files "bootstrap" "bootstrap.sh" "autogen" "autogen.sh"
               (else
                (format #t "bootstrapping with `autoreconf'...~%")
                (invoke "autoreconf" "-vfi")))))

(define* (build #:key build-before-dist? make-flags (dist-target "distcheck")
                #:allow-other-keys
                #:rest args)
  (when build-before-dist?
    (let ((build (assq-ref %standard-phases 'build)))
      (apply build args)))
  (format #t "building target `~a'~%" dist-target)
  (apply invoke "make" dist-target make-flags))

(define* (install-dist #:key outputs #:allow-other-keys)
  (let* ((out      (assoc-ref outputs "out"))
         (meta     (string-append out "/nix-support")) ; Hydra meta-data
         (tarballs (find-files "." "\\.tar\\.")))
    (mkdir out)
    (for-each (lambda (tarball)
                (copy-file tarball (string-append out "/" tarball)))
              out)

    (mkdir meta)
    (call-with-output-file (string-append out "/hydra-build-products")
      (lambda (port)
        (for-each (lambda (tarball)
                    ;; This tells Hydra's what kind of build products we have,
                    ;; so it can represent them nicely.  See `product-list.tt'
                    ;; in Hydra for details.
                    (format port "file source-dist ~a/~a~%" out tarball))
                  tarballs)))
    #t))

(define %dist-phases
  ;; Phases for building a source tarball.
  (modify-phases %standard-phases
    (delete 'strip)
    (replace 'install install-dist)
    (replace 'build build)
    (add-before 'configure 'autoreconf autoreconf)
    (replace 'unpack copy-source)))

;;; gnu-dist.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Petter <petter@mykolab.ch>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build go-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:export (%standard-phases
            go-build))

;; Commentary:
;;
;; Build procedures for Go packages.  This is the builder-side code.
;;
;; Software written in Go is either a 'package' (i.e. library) or 'command'
;; (i.e. executable).  Both types can be built with either the `go build` or `go
;; install` commands.  However, `go build` discards the result of the build
;; process for Go libraries, so we use `go install`, which preserves the
;; results. [0]

;; Go software is developed and built within a particular file system hierarchy
;; structure called a 'workspace' [1].  This workspace is found by Go
;; via the GOPATH environment variable.  Typically, all Go source code
;; and compiled objects are kept in a single workspace, but it is
;; possible for GOPATH to contain a list of directories, and that is
;; what we do in this go-build-system. [2]
;;
;; Go software, whether a package or a command, is uniquely named using
;; an 'import path'.  The import path is based on the URL of the
;; software's source.  Since most source code is provided over the
;; internet, the import path is typically a combination of the remote
;; URL and the source repository's file system structure. For example,
;; the Go port of the common `du` command is hosted on github.com, at
;; <https://github.com/calmh/du>.  Thus, the import path is
;; <github.com/calmh/du>. [3]
;;
;; It may be possible to programatically guess a package's import path
;; based on the source URL, but we don't try that in this revision of
;; the go-build-system.
;;
;; Modules of modular Go libraries are named uniquely with their
;; file system paths.  For example, the supplemental but "standardized"
;; libraries developed by the Go upstream developers are available at
;; <https://golang.org/x/{net,text,crypto, et cetera}>.  The Go IPv4
;; library's import path is <golang.org/x/net/ipv4>.  The source of
;; such modular libraries must be unpacked at the top-level of the
;; file system structure of the library.  So the IPv4 library should be
;; unpacked to <golang.org/x/net>.  This is handled in the
;; go-build-system with the optional #:unpack-path key.
;;
;; In general, Go software is built using a standardized build mechanism
;; that does not require any build scripts like Makefiles.  This means
;; that all modules of modular libraries cannot be built with a single
;; command.  Each module must be built individually.  This complicates
;; certain cases, and these issues are currently resolved by creating a
;; file system union of the required modules of such libraries.  I think
;; this could be improved in future revisions of the go-build-system.
;;
;; [0] `go build`:
;; https://golang.org/cmd/go/#hdr-Compile_packages_and_dependencies
;; `go install`:
;; https://golang.org/cmd/go/#hdr-Compile_and_install_packages_and_dependencies
;; [1] Go workspace example, from <https://golang.org/doc/code.html#Workspaces>:
;; bin/
;;     hello                          # command executable
;;     outyet                         # command executable
;; pkg/
;;     linux_amd64/
;;         github.com/golang/example/
;;             stringutil.a           # package object
;; src/
;;     github.com/golang/example/
;;         .git/                      # Git repository metadata
;; 	   hello/
;; 	       hello.go               # command source
;; 	   outyet/
;; 	        main.go               # command source
;; 	        main_test.go          # test source
;; 	   stringutil/
;; 	       reverse.go             # package source
;; 	       reverse_test.go        # test source
;;         golang.org/x/image/
;;             .git/                  # Git repository metadata
;; 	       bmp/
;; 	           reader.go          # package source
;; 	           writer.go          # package source
;;     ... (many more repositories and packages omitted) ...
;;
;; [2] https://golang.org/doc/code.html#GOPATH
;; [3] https://golang.org/doc/code.html#ImportPaths
;;
;; Code:

(define* (unpack #:key source import-path unpack-path #:allow-other-keys)
  "Unpack SOURCE in the UNPACK-PATH, or the IMPORT-PATH is the UNPACK-PATH is
unset.  When SOURCE is a directory, copy it instead of unpacking."
  (if (string-null? import-path)
      ((display "WARNING: The Go import path is unset.\n")))
  (if (string-null? unpack-path)
      (set! unpack-path import-path))
  (mkdir "src")
  (let ((dest (string-append "src/" unpack-path)))
    (mkdir-p dest)
    (if (file-is-directory? source)
      (begin
        (copy-recursively source dest #:keep-mtime? #t)
        #t)
      (if (string-suffix? ".zip" source)
        (invoke "unzip" "-d" dest source)
        (invoke "tar" "-C" dest "-xvf" source)))))

(define* (install-source #:key install-source? outputs #:allow-other-keys)
  "Install the source code to the output directory."
  (let* ((out (assoc-ref outputs "out"))
         (source "src")
         (dest (string-append out "/" source)))
    (when install-source?
      (copy-recursively source dest #:keep-mtime? #t))
    #t))

(define (go-package? name)
  (string-prefix? "go-" name))

(define (go-inputs inputs)
  "Return the alist of INPUTS that are Go software."
  ;; XXX This should not check the file name of the store item. Instead we
  ;; should pass, from the host side, the list of inputs that are packages using
  ;; the go-build-system.
  (alist-delete "go" ; Exclude the Go compiler
    (alist-delete "source" ; Exclude the source code of the package being built
      (filter (match-lambda
                ((label . directory)
                 (go-package? ((compose package-name->name+version
                                        strip-store-file-name)
                               directory)))
                (_ #f))
              inputs))))

(define* (setup-environment #:key inputs outputs #:allow-other-keys)
  "Export the variables GOPATH and GOBIN, which are based on INPUTS and OUTPUTS,
respectively."
  (let ((out (assoc-ref outputs "out")))
    ;; GOPATH is where Go looks for the source code of the build's dependencies.
    (set-path-environment-variable "GOPATH"
                                   ;; XXX Matching "." hints that we could do
                                   ;; something simpler here...
                                   (list ".")
                                   (match (go-inputs inputs)
                                     (((_ . dir) ...)
                                      dir)))

    ;; Add the source code of the package being built to GOPATH.
    (if (getenv "GOPATH")
      (setenv "GOPATH" (string-append (getcwd) ":" (getenv "GOPATH")))
      (setenv "GOPATH" (getcwd)))
    ;; Where to install compiled executable files ('commands' in Go parlance').
    (setenv "GOBIN" (string-append out "/bin"))
    #t))

(define* (build #:key import-path #:allow-other-keys)
  "Build the package named by IMPORT-PATH."
  (with-throw-handler
    #t
    (lambda _
      (invoke "go" "install"
              "-v" ; print the name of packages as they are compiled
              "-x" ; print each command as it is invoked
              ;; Respectively, strip the symbol table and debug
              ;; information, and the DWARF symbol table.
              "-ldflags=-s -w"
              import-path))
    (lambda (key . args)
      (display (string-append "Building '" import-path "' failed.\n"
                              "Here are the results of `go env`:\n"))
      (invoke "go" "env"))))

(define* (check #:key tests? import-path #:allow-other-keys)
  "Run the tests for the package named by IMPORT-PATH."
  (when tests?
    (invoke "go" "test" import-path))
  #t)

(define* (install #:key outputs #:allow-other-keys)
  "Install the compiled libraries. `go install` installs these files to
$GOPATH/pkg, so we have to copy them into the output directory manually.
Compiled executable files should have already been installed to the store based
on $GOBIN in the build phase."
  (when (file-exists? "pkg")
    (copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg")))
  #t)

(define* (remove-store-reference file file-name
                                  #:optional (store (%store-directory)))
  "Remove from FILE occurrences of FILE-NAME in STORE; return #t when FILE-NAME
is encountered in FILE, #f otherwise. This implementation reads FILE one byte at
a time, which is slow. Instead, we should use the Boyer-Moore string search
algorithm; there is an example in (guix build grafts)."
  (define pattern
    (string-take file-name
                 (+ 34 (string-length (%store-directory)))))

  (with-fluids ((%default-port-encoding #f))
    (with-atomic-file-replacement file
      (lambda (in out)
        ;; We cannot use `regexp-exec' here because it cannot deal with
        ;; strings containing NUL characters.
        (format #t "removing references to `~a' from `~a'...~%" file-name file)
        (setvbuf in 'block 65536)
        (setvbuf out 'block 65536)
        (fold-port-matches (lambda (match result)
                             (put-bytevector out (string->utf8 store))
                             (put-u8 out (char->integer #\/))
                             (put-bytevector out
                                             (string->utf8
                                              "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-"))
                             #t)
                           #f
                           pattern
                           in
                           (lambda (char result)
                             (put-u8 out (char->integer char))
                             result))))))

(define* (remove-go-references #:key allow-go-reference?
                               inputs outputs #:allow-other-keys)
  "Remove any references to the Go compiler from the compiled Go executable
files in OUTPUTS."
;; We remove this spurious reference to save bandwidth when installing Go
;; executables. It would be better to not embed the reference in the first
;; place, but I'm not sure how to do that. The subject was discussed at:
;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00207.html>
  (if allow-go-reference?
    #t
    (let ((go (assoc-ref inputs "go"))
          (bin "/bin"))
      (for-each (lambda (output)
                  (when (file-exists? (string-append (cdr output)
                                                     bin))
                    (for-each (lambda (file)
                                (remove-store-reference file go))
                              (find-files (string-append (cdr output) bin)))))
                outputs)
      #t)))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'patch-generated-file-shebangs)
    (replace 'unpack unpack)
    (add-after 'unpack 'install-source install-source)
    (add-before 'build 'setup-environment setup-environment)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)
    (add-after 'install 'remove-go-references remove-go-references)))

(define* (go-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given Go package, applying all of PHASES in order."
  (apply gnu:gnu-build #:inputs inputs #:phases phases args))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix build graft)
  #:use-module (guix build utils)
  #:use-module (guix build debug-link)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 binary-ports)
  #:use-module (srfi srfi-1)   ; list library
  #:use-module (srfi srfi-26)  ; cut and cute
  #:export (replace-store-references
            rewrite-directory
            graft))

;;; Commentary:
;;;
;;; This module supports "grafts".  Grafting a directory means rewriting it,
;;; with references to some specific items replaced by references to other
;;; store items---the grafts.
;;;
;;; This method is used to provide fast security updates as only the leaves of
;;; the dependency graph need to be grafted, even when the security updates
;;; affect a core component such as Bash or libc.  It is based on the idea of
;;; 'replace-dependency' implemented by Shea Levy in Nixpkgs.
;;;
;;; Code:

(define-syntax-rule (define-inline name val)
  (define-syntax name (identifier-syntax val)))

(define-inline hash-length 32)

(define nix-base32-char?
  (cute char-set-contains?
        ;; ASCII digits and lower case letters except e o t u
        (string->char-set "0123456789abcdfghijklmnpqrsvwxyz")
        <>))

(define* (replace-store-references input output replacement-table
                                   #:optional (store (%store-directory)))
  "Read data from INPUT, replacing store references according to
REPLACEMENT-TABLE, and writing the result to OUTPUT.  REPLACEMENT-TABLE is a
vhash that maps strings (original hashes) to bytevectors (replacement strings
comprising the replacement hash, a dash, and a string).

Note: We use string keys to work around the fact that guile-2.0 hashes all
bytevectors to the same value."

  (define (lookup-replacement s)
    (match (vhash-assoc s replacement-table)
      ((origin . replacement)
       replacement)
      (#f #f)))

  (define (optimize-u8-predicate pred)
    (cute vector-ref
          (list->vector (map pred (iota 256)))
          <>))

  (define nix-base32-byte?
    (optimize-u8-predicate
     (compose nix-base32-char?
              integer->char)))

  (define (dash? byte) (= byte 45))

  (define request-size (expt 2 20))  ; 1 MiB

  ;; We scan the file for the following 33-byte pattern: 32 bytes of
  ;; nix-base32 characters followed by a dash.  To accommodate large files,
  ;; we do not read the entire file, but instead work on buffers of up to
  ;; 'request-size' bytes.  To ensure that every 33-byte sequence appears
  ;; entirely within exactly one buffer, adjacent buffers must overlap,
  ;; i.e. they must share 32 byte positions.  We accomplish this by
  ;; "ungetting" the last 32 bytes of each buffer before reading the next
  ;; buffer, unless we know that we've reached the end-of-file.
  (let ((buffer (make-bytevector request-size)))
    (let loop ()
      ;; Note: We avoid 'get-bytevector-n' to work around
      ;; <http://bugs.gnu.org/17466>.
      (match (get-bytevector-n! input buffer 0 request-size)
        ((? eof-object?) 'done)
        (end
         ;; We scan the buffer for dashes that might be preceded by a
         ;; nix-base32 hash.  The key optimization here is that whenever we
         ;; find a NON-nix-base32 character at position 'i', we know that it
         ;; cannot be part of a hash, so the earliest position where the next
         ;; hash could start is i+1 with the following dash at position i+33.
         ;;
         ;; Since nix-base32 characters comprise only 1/8 of the 256 possible
         ;; byte values, and exclude some of the most common letters in
         ;; English text (e t o u), in practice we can advance by 33 positions
         ;; most of the time.
         (let scan-from ((i hash-length) (written 0))
           ;; 'i' is the first position where we look for a dash.  'written'
           ;; is the number of bytes in the buffer that have already been
           ;; written.
           (if (< i end)
               (let ((byte (bytevector-u8-ref buffer i)))
                 (cond ((and (dash? byte)
                             ;; We've found a dash.  Note that we do not know
                             ;; whether the preceeding 32 bytes are nix-base32
                             ;; characters, but we do not need to know.  If
                             ;; they are not, the following lookup will fail.
                             (lookup-replacement
                              (string-tabulate (lambda (j)
                                                 (integer->char
                                                  (bytevector-u8-ref buffer
                                                   (+ j (- i hash-length)))))
                                               hash-length)))
                        => (lambda (replacement)
                             ;; We've found a hash that needs to be replaced.
                             ;; First, write out all bytes preceding the hash
                             ;; that have not yet been written.
                             (put-bytevector output buffer written
                                             (- i hash-length written))
                             ;; Now write the replacement string.
                             (put-bytevector output replacement)
                             ;; Since the byte at position 'i' is a dash,
                             ;; which is not a nix-base32 char, the earliest
                             ;; position where the next hash might start is
                             ;; i+1, and the earliest position where the
                             ;; following dash might start is (+ i 1
                             ;; hash-length).  Also, increase the write
                             ;; position to account for REPLACEMENT.
                             (let ((len (bytevector-length replacement)))
                               (scan-from (+ i 1 len)
                                          (+ i (- len hash-length))))))
                       ;; If the byte at position 'i' is a nix-base32 char,
                       ;; then the dash we're looking for might be as early as
                       ;; the following byte, so we can only advance by 1.
                       ((nix-base32-byte? byte)
                        (scan-from (+ i 1) written))
                       ;; If the byte at position 'i' is NOT a nix-base32
                       ;; char, then the earliest position where the next hash
                       ;; might start is i+1, with the following dash at
                       ;; position (+ i 1 hash-length).
                       (else
                        (scan-from (+ i 1 hash-length) written))))

               ;; We have finished scanning the buffer.  Now we determine how
               ;; many bytes have not yet been written, and how many bytes to
               ;; "unget".  If 'end' is less than 'request-size' then we read
               ;; less than we asked for, which indicates that we are at EOF,
               ;; so we needn't unget anything.  Otherwise, we unget up to
               ;; 'hash-length' bytes (32 bytes).  However, we must be careful
               ;; not to unget bytes that have already been written, because
               ;; that would cause them to be written again from the next
               ;; buffer.  In practice, this case occurs when a replacement is
               ;; made near or beyond the end of the buffer.  When REPLACEMENT
               ;; went beyond END, we consume the extra bytes from INPUT.
               (begin
                 (if (> written end)
                     (get-bytevector-n! input buffer 0 (- written end))
                     (let* ((unwritten  (- end written))
                            (unget-size (if (= end request-size)
                                            (min hash-length unwritten)
                                            0))
                            (write-size (- unwritten unget-size)))
                       (put-bytevector output buffer written write-size)
                       (unget-bytevector input buffer (+ written write-size)
                                         unget-size)))
                 (loop)))))))))

(define (rename-matching-files directory mapping)
  "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is
a list of store file name pairs."
  (let* ((mapping (map (match-lambda
                        ((source . target)
                         (cons (basename source) (basename target))))
                       mapping))
         (matches (find-files directory
                              (lambda (file stat)
                                (assoc-ref mapping (basename file)))
                              #:directories? #t)))

    ;; XXX: This is not quite correct: if MAPPING contains "foo", and
    ;; DIRECTORY contains "bar/foo/foo", we first rename "bar/foo" and then
    ;; "bar/foo/foo" no longer exists so we fail.  Oh well, surely that's good
    ;; enough!
    (for-each (lambda (file)
                (let ((target (assoc-ref mapping (basename file))))
                  (rename-file file
                               (string-append (dirname file) "/" target))))
              matches)))

(define (exit-on-exception proc)
  "Return a procedure that wraps PROC so that 'primitive-exit' is called when
an exception is caught."
  (lambda (arg)
    (catch #t
      (lambda ()
        (proc arg))
      (lambda (key . args)
        ;; Since ports are not thread-safe as of Guile 2.0, reopen stderr.
        (let ((port (fdopen 2 "w0")))
          (print-exception port #f key args)
          (primitive-exit 1))))))

;; We need this as long as we support Guile < 2.0.13.
(define* (mkdir-p* dir #:optional (mode #o755))
  "This is a variant of 'mkdir-p' that works around
<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
  (define absolute?
    (string-prefix? "/" dir))

  (define not-slash
    (char-set-complement (char-set #\/)))

  (let loop ((components (string-tokenize dir not-slash))
             (root       (if absolute?
                             ""
                             ".")))
    (match components
      ((head tail ...)
       (let ((path (string-append root "/" head)))
         (catch 'system-error
           (lambda ()
             (mkdir path mode)
             (loop tail path))
           (lambda args
             (if (= EEXIST (system-error-errno args))
                 (loop tail path)
                 (apply throw args))))))
      (() #t))))

(define* (rewrite-directory directory output mapping
                            #:optional (store (%store-directory)))
  "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
file name pairs."

  (define hash-mapping
    ;; List of hash/replacement pairs, where the hash is a nix-base32 string
    ;; and the replacement is a string that includes the replacement's name,
    ;; like "r837zajjc1q8z9hph4b6860a9c05blyy-openssl-1.0.2j".
    (let* ((prefix (string-append store "/"))
           (start  (string-length prefix))
           (end    (+ start hash-length)))
      (define (valid-hash? h)
        (every nix-base32-char? (string->list h)))
      (define (hash+rest s)
        (and (< end (string-length s))
             (let ((hash (substring s start end))
                   (all  (substring s start)))
               (and (string-prefix? prefix s)
                    (valid-hash? hash)
                    (eqv? #\- (string-ref s end))
                    (list hash all)))))

      (map (match-lambda
             (((= hash+rest (origin-hash origin-string))
               .
               (= hash+rest (replacement-hash replacement-string)))
              (unless (= (string-length origin-string)
                         (string-length replacement-string))
                (error "replacement length differs from the original length"
                       origin-string replacement-string))
              (cons origin-hash (string->utf8 replacement-string)))
             ((origin . replacement)
              (error "invalid replacement" origin replacement)))
           mapping)))

  (define replacement-table
    (alist->vhash hash-mapping))

  (define prefix-len
    (string-length directory))

  (define (destination file)
    (string-append output (string-drop file prefix-len)))

  (define (rewrite-leaf file)
    (let ((stat (lstat file))
          (dest (destination file)))
      (mkdir-p* (dirname dest))
      (case (stat:type stat)
        ((symlink)
         (let ((target (readlink file)))
           (symlink (call-with-output-string
                      (lambda (output)
                        (replace-store-references (open-input-string target)
                                                  output replacement-table
                                                  store)))
                    dest)))
        ((regular)
         (call-with-input-file file
           (lambda (input)
             (call-with-output-file dest
               (lambda (output)
                 (replace-store-references input output replacement-table
                                           store)
                 (chmod output (stat:perms stat)))))))
        ((directory)
         (mkdir-p* dest))
        (else
         (error "unsupported file type" stat)))))

  ;; Use 'exit-on-exception' to force an exit upon I/O errors, given that
  ;; 'n-par-for-each' silently swallows exceptions.
  ;; See <http://bugs.gnu.org/23581>.
  (n-par-for-each (parallel-job-count)
                  (exit-on-exception rewrite-leaf)
                  (find-files directory (const #t)
                              #:directories? #t))
  (rename-matching-files output mapping))

(define %graft-hooks
  ;; Default list of hooks run after grafting.
  (list graft-debug-links))

(define* (graft old-outputs new-outputs mapping
                #:key (log-port (current-output-port))
                (hooks %graft-hooks))
  "Apply the grafts described by MAPPING on OLD-OUTPUTS, leading to
NEW-OUTPUTS.  MAPPING must be a list of file name pairs; OLD-OUTPUTS and
NEW-OUTPUTS are lists of output name/file name pairs."
  (for-each (lambda (input output)
              (format log-port "grafting '~a' -> '~a'...~%" input output)
              (force-output)
              (rewrite-directory input output mapping))
            (match old-outputs
              (((names . files) ...)
               files))
            (match new-outputs
              (((names . files) ...)
               files)))
  (for-each (lambda (hook)
              (hook old-outputs new-outputs mapping
                    #:log-port log-port))
            hooks))

;;; graft.scm ends here