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 © 2020 Timothy Sample <samplet@ngyro.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/>.

;; Commentary:
;;
;; These procedures can be used to adapt the GNU Build System to build
;; pure Scheme packages targeting the bootstrap Guile.
;;
;; Code:

(define-module (guix build gnu-bootstrap)
  #:use-module (guix build utils)
  #:use-module (system base compile)
  #:export (bootstrap-configure
            bootstrap-build
            bootstrap-install))

(define (bootstrap-configure version modules scripts)
  "Create a procedure that configures an early bootstrap package.  The
procedure will search the MODULES directory and configure all of the
'.in' files with VERSION.  It will then search the SCRIPTS directory and
configure all of the '.in' files with the bootstrap Guile and its module
and object directories."
  (lambda* (#:key inputs outputs #:allow-other-keys)
    (let* ((out (assoc-ref outputs "out"))
           (guile-dir (assoc-ref inputs "guile"))
           (guile (string-append guile-dir "/bin/guile"))
           (moddir (string-append out "/share/guile/site/"
                                  (effective-version)))
           (godir (string-append out "/lib/guile/"
                                 (effective-version)
                                 "/site-ccache")))
      (for-each (lambda (template)
                  (format #t "Configuring ~a~%" template)
                  (let ((target (string-drop-right template 3)))
                    (copy-file template target)
                    (substitute* target
                      (("@VERSION@") version))))
                (find-files modules
                            (lambda (fn st)
                              (string-suffix? ".in" fn))))
      (for-each (lambda (template)
                  (format #t "Configuring ~a~%" template)
                  (let ((target (string-drop-right template 3)))
                    (copy-file template target)
                    (substitute* target
                      (("@GUILE@") guile)
                      (("@MODDIR@") moddir)
                      (("@GODIR@") godir))
                    (chmod target #o755)))
                (find-files scripts
                            (lambda (fn st)
                              (string-suffix? ".in" fn))))
      #t)))

(define (bootstrap-build modules)
  "Create a procedure that builds an early bootstrap package.  The
procedure will search the MODULES directory and compile all of the
'.scm' files."
  (lambda _
    (add-to-load-path (getcwd))
    (for-each (lambda (scm)
                (let* ((base (string-drop-right scm 4))
                       (go (string-append base ".go"))
                       (dir (dirname scm)))
                  (format #t "Compiling ~a~%" scm)
                  (compile-file scm #:output-file go)))
              (find-files modules "\\.scm$"))
    #t))

(define (bootstrap-install modules scripts)
  "Create a procedure that installs an early bootstrap package.  The
procedure will install all of the '.scm' and '.go' files in the MODULES
directory, and all the executable files in the SCRIPTS directory."
  (lambda* (#:key inputs outputs #:allow-other-keys)
    (let* ((out (assoc-ref outputs "out"))
           (guile-dir (assoc-ref inputs "guile"))
           (guile (string-append guile-dir "/bin/guile"))
           (moddir (string-append out "/share/guile/site/"
                                  (effective-version)))
           (godir (string-append out "/lib/guile/"
                                 (effective-version)
                                 "/site-ccache")))
      (for-each (lambda (scm)
                  (let* ((base (string-drop-right scm 4))
                         (go (string-append base ".go"))
                         (dir (dirname scm)))
                    (format #t "Installing ~a~%" scm)
                    (install-file scm (string-append moddir "/" dir))
                    (format #t "Installing ~a~%" go)
                    (install-file go (string-append godir "/" dir))))
                (find-files modules "\\.scm$"))
      (for-each (lambda (script)
                  (format #t "Installing ~a~%" script)
                  (install-file script (string-append out "/bin")))
                (find-files scripts
                            (lambda (fn st)
                              (executable-file? fn))))
      #t)))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot>
;;;
;;; 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 (ice-9 ftw)
  #: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 directory)
  "Return the file name of the first sub-directory of DIRECTORY."
  (match (scandir directory
                  (lambda (file)
                    (and (not (member file '("." "..")))
                         (file-is-directory? (string-append directory "/"
                                                            file)))))
    ((first . _) first)))

(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.
  (define (script-exists? file)
    (and (file-exists? file)
         (not (file-is-directory? file))))

  (if (not (script-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 script-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)))
              (setenv "NOCONFIGURE" "true")
              (format #t "running '~a'~%" script)
              (if (executable-file? script)
                  (begin
                    (patch-shebang script)
                    (invoke script))
                  (invoke "sh" script))
              ;; Let's clean up after ourselves.
              (unsetenv "NOCONFIGURE"))
            (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)
                                out-of-source?
                                #:allow-other-keys)
  "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
  (define (find-source-directory package)
    ;; For an out-of-source build, guess the source directory location
    ;; relative to the current directory.  Return #f on failure.
    (match (scandir ".."
                    (lambda (file)
                      (and (not (member file '("." ".." "build")))
                           (file-is-directory?
                            (string-append "../" file)))))
      (()                                         ;hmm, no source
       #f)
      ((source)                                   ;only one other file
       (string-append "../" source))
      ((directories ...)                          ;pick the most likely one
       ;; This happens for example with libstdc++, which lives within the GCC
       ;; source tree.
       (any (lambda (directory)
              (and (string-prefix? package directory)
                   (string-append "../" directory)))
            directories))))

  (define (copy-to-directories directories sub-directory)
    (lambda (file)
      (for-each (if (file-is-directory? file)
                    (cut copy-recursively file <>)
                    (cut install-file file <>))
                (map (cut string-append <> "/" sub-directory)
                     directories))))

  (let* ((regexp    (make-regexp license-file-regexp))
         (out       (or (assoc-ref outputs "out")
                        (match outputs
                          (((_ . output) _ ...)
                           output))))
         (package   (strip-store-file-name out))
         (outputs   (match outputs
                      (((_ . outputs) ...)
                       outputs)))
         (source    (if out-of-source?
                        (find-source-directory
                         (package-name->name+version package))
                        "."))
         (files     (and source
                         (scandir source
                                  (lambda (file)
                                    (regexp-exec regexp file))))))
    (if files
        (begin
          (format #t "installing ~a license files from '~a'~%"
                  (length files) source)
          (for-each (copy-to-directories outputs
                                         (string-append "share/doc/"
                                                        package))
                    (map (cut string-append source "/" <>) files)))
        (format (current-error-port)
                "failed to find license 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) 'line)
  (setvbuf (current-error-port) 'line)

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

  (guard (c ((invoke-error? c)
             (report-invoke-error c)
             (exit 1)))
    ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
    ;; PHASES can pick the keyword arguments it's interested in.
    (every (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, 2020 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* (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")))
    (for-each (lambda (tarball)
                (install-file tarball out))
              (find-files "." "\\.tar\\."))
    #t))

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

;;; gnu-dist.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Petter <petter@mykolab.ch>
;;; Copyright © 2017, 2019 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 union)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #: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 can be found by Go via
;; the GOPATH environment variable.  Typically, all Go source code and compiled
;; objects are kept in a single workspace, but GOPATH may be a list of
;; directories [2].  In this go-build-system we create a file system union of
;; the Go-language dependencies. Previously, we made GOPATH a list of store
;; directories, but stopped because Go programs started keeping references to
;; these directories in Go 1.11:
;; <https://bugs.gnu.org/33620>.
;;
;; 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.
;; Because 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 automatically 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.
;;
;; TODO:
;; * Avoid copying dependencies into the build environment and / or avoid using
;; a tmpdir when creating the inputs union.
;; * Use Go modules [4]
;; * Re-use compiled packages [5]
;; * Avoid the go-inputs hack
;; * Stop needing remove-go-references (-trimpath ? )
;; * Remove module packages, only offering the full Git repos? This is
;; more idiomatic, I think, because Go downloads Git repos, not modules.
;; What are the trade-offs?
;;
;; [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
;; [4] https://golang.org/cmd/go/#hdr-Modules__module_versions__and_more
;; [5] https://bugs.gnu.org/32919
;;
;; Code:

(define* (setup-go-environment #:key inputs outputs #:allow-other-keys)
  "Prepare a Go build environment for INPUTS and OUTPUTS.  Build a file system
union of INPUTS.  Export GOPATH, which helps the compiler find the source code
of the package being built and its dependencies, and GOBIN, which determines
where executables (\"commands\") are installed to.  This phase is sometimes used
by packages that use (guix build-system gnu) but have a handful of Go
dependencies, so it should be self-contained."
  ;; The Go cache is required starting in Go 1.12.  We don't actually use it but
  ;; we need it to be a writable directory.
  (setenv "GOCACHE" "/tmp/go-cache")
  ;; Using the current working directory as GOPATH makes it easier for packagers
  ;; who need to manipulate the unpacked source code.
  (setenv "GOPATH" (getcwd))
  ;; Go 1.13 uses go modules by default. The go build system does not
  ;; currently support modules, so turn modules off to continue using the old
  ;; GOPATH behavior.
  (setenv "GO111MODULE" "off")
  (setenv "GOBIN" (string-append (assoc-ref outputs "out") "/bin"))
  (let ((tmpdir (tmpnam)))
    (match (go-inputs inputs)
      (((names . directories) ...)
       (union-build tmpdir (filter directory-exists? directories)
                    #:create-all-directories? #t
                    #:log-port (%make-void-port "w"))))
    ;; XXX A little dance because (guix build union) doesn't use mkdir-p.
    (copy-recursively tmpdir
                      (string-append (getenv "GOPATH"))
                      #:keep-mtime? #t)
    (delete-file-recursively tmpdir))
  #t)

(define* (unpack #:key source import-path unpack-path #:allow-other-keys)
  "Relative to $GOPATH, unpack SOURCE in UNPACK-PATH, or IMPORT-PATH when
UNPACK-PATH is unset.  If the SOURCE archive has a single top level directory,
it is stripped so that the sources appear directly under UNPACK-PATH.  When
SOURCE is a directory, copy its content into UNPACK-PATH instead of
unpacking."
  (define (unpack-maybe-strip source dest)
    (let* ((scratch-dir (string-append (or (getenv "TMPDIR") "/tmp")
                                       "/scratch-dir"))
           (out (mkdir-p scratch-dir)))
      (with-directory-excursion scratch-dir
        (if (string-suffix? ".zip" source)
            (invoke "unzip" source)
            (invoke "tar" "-xvf" source))
        (let ((top-level-files (remove (lambda (x)
                                         (member x '("." "..")))
                                       (scandir "."))))
          (match top-level-files
            ((top-level-file)
             (when (file-is-directory? top-level-file)
               (copy-recursively top-level-file dest #:keep-mtime? #t)))
            (_
             (copy-recursively "." dest #:keep-mtime? #t)))))
      (delete-file-recursively scratch-dir)))

  (when (string-null? import-path)
    (display "WARNING: The Go import path is unset.\n"))
  (when (string-null? unpack-path)
    (set! unpack-path import-path))
  (let ((dest (string-append (getenv "GOPATH") "/src/" unpack-path)))
    (mkdir-p dest)
    (if (file-is-directory? source)
        (copy-recursively source dest #:keep-mtime? #t)
        (unpack-maybe-strip source dest)))
  #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* (build #:key import-path build-flags #:allow-other-keys)
  "Build the package named by IMPORT-PATH."
  (with-throw-handler
    #t
    (lambda _
      (apply 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"
              `(,@build-flags ,import-path)))
    (lambda (key . args)
      (display (string-append "Building '" import-path "' failed.\n"
                              "Here are the results of `go env`:\n"))
      (invoke "go" "env"))))

;; Can this also install commands???
(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 install-source? outputs import-path unpack-path #:allow-other-keys)
  "Install the source code of IMPORT-PATH to the primary output directory.
Compiled executable files (Go \"commands\") should have already been installed
to the store based on $GOBIN in the build phase.
XXX We can't make use of compiled libraries (Go \"packages\")."
  (when install-source?
    (if (string-null? import-path)
        ((display "WARNING: The Go import path is unset.\n")))
    (let* ((out (assoc-ref outputs "out"))
           (source (string-append (getenv "GOPATH") "/src/" import-path))
           (dest (string-append out "/src/" import-path)))
      (mkdir-p dest)
      (copy-recursively source dest #:keep-mtime? #t)))
  #t)

(define* (install-license-files #:key unpack-path
                                import-path
                                #:allow-other-keys
                                #:rest args)
  "Install license files matching LICENSE-FILE-REGEXP to 'share/doc'.  Adjust
the standard install-license-files phase to first enter the correct directory."
  (with-directory-excursion (string-append "src/" (if (string-null? unpack-path)
                                                    import-path
                                                    unpack-path))
    (apply (assoc-ref gnu:%standard-phases 'install-license-files) args)))

(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)
    (add-before 'unpack 'setup-go-environment setup-go-environment)
    (replace 'unpack unpack)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)
    (replace 'install-license-files install-license-files)
    (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, 2021 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 (nix-base32-char-or-nul? c)
  "Return true if C is a nix-base32 character or NUL, otherwise return false."
  (or (nix-base32-char? c)
      (char=? c #\nul)))

(define (possible-utf16-hash? buffer i w)
  "Return true if (I - W) is large enough to hold a UTF-16 encoded
nix-base32 hash and if BUFFER contains NULs in all positions where NULs
are to be expected in a UTF-16 encoded hash+dash pattern whose dash is
found at position I.  Otherwise, return false."
  (and (<= (* 2 hash-length) (- i w))
       (let loop ((j (+ 1 (- i (* 2 hash-length)))))
         (or (>= j i)
             (and (zero? (bytevector-u8-ref buffer j))
                  (loop (+ j 2)))))))

(define (possible-utf32-hash? buffer i w)
  "Return true if (I - W) is large enough to hold a UTF-32 encoded
nix-base32 hash and if BUFFER contains NULs in all positions where NULs
are to be expected in a UTF-32 encoded hash+dash pattern whose dash is
found at position I.  Otherwise, return false."
  (and (<= (* 4 hash-length) (- i w))
       (let loop ((j (+ 1 (- i (* 4 hash-length)))))
         (or (>= j i)
             (and (zero? (bytevector-u8-ref buffer j))
                  (zero? (bytevector-u8-ref buffer (+ j 1)))
                  (zero? (bytevector-u8-ref buffer (+ j 2)))
                  (loop (+ j 4)))))))

(define (insert-nuls char-size bv)
  "Given a bytevector BV, return a bytevector containing the same bytes but
with (CHAR-SIZE - 1) NULs inserted between every two adjacent bytes from BV.
For example, (insert-nuls 4 #u8(1 2 3)) => #u8(1 0 0 0 2 0 0 0 3)."
  (if (= char-size 1)
      bv
      (let* ((len (bytevector-length bv))
             (bv* (make-bytevector (+ 1 (* char-size
                                           (- len 1)))
                                   0)))
        (let loop ((i 0))
          (when (< i len)
            (bytevector-u8-set! bv* (* i char-size)
                                (bytevector-u8-ref bv i))
            (loop (+ i 1))))
        bv*)))

(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-or-nul?
    (optimize-u8-predicate
     (compose nix-base32-char-or-nul?
              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.  When we find such a pattern
  ;; whose hash is in REPLACEMENT-TABLE, we perform the required rewrite and
  ;; continue scanning.
  ;;
  ;; To support UTF-16 and UTF-32 store references, the 33 bytes comprising
  ;; this hash+dash pattern may optionally be interspersed by extra NUL bytes.
  ;; This simple approach works because the characters we are looking for are
  ;; restricted to ASCII.  UTF-16 hashes are interspersed with single NUL
  ;; bytes ("\0"), and UTF-32 hashes are interspersed with triplets of NULs
  ;; ("\0\0\0").  Note that we require NULs to be present only *between* the
  ;; other bytes, and not at either end, in order to be insensitive to byte
  ;; order.
  ;;
  ;; To accommodate large files, we do not read the entire file at once, but
  ;; instead work on buffers of up to REQUEST-SIZE bytes.  To ensure that
  ;; every hash+dash pattern appears in its entirety in at least one buffer,
  ;; adjacent buffers must overlap by one byte less than the maximum size of a
  ;; hash+dash pattern.  We accomplish this by "ungetting" a suffix 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)))
    (define-syntax-rule (byte-at i)
      (bytevector-u8-ref buffer i))
    (let outer-loop ()
      (match (get-bytevector-n! input buffer 0 request-size)
        ((? eof-object?) 'done)
        (end
         (define (scan-from i w)
           ;; Scan the buffer for dashes that might be preceded by nix hashes,
           ;; where I is the minimum position where such a dash might be
           ;; found, and W is the number of bytes in the buffer that have been
           ;; written so far.  We assume that I - W >= HASH-LENGTH.
           ;;
           ;; The key optimization here is that whenever we find a byte at
           ;; position I that cannot occur within a nix hash (because it's
           ;; neither a nix-base32 character nor NUL), we can infer that the
           ;; earliest position where the next hash could start is at I + 1,
           ;; and therefore the earliest position for the following dash is
           ;; (+ I 1 HASH-LENGTH), which is I + 33.
           ;;
           ;; Since nix-base32-or-nul characters comprise only about 1/8 of
           ;; the 256 possible byte values, and exclude some of the most
           ;; common letters in English text (e t o u), we can advance 33
           ;; positions much of the time.
           (if (< i end)
               (let ((byte (byte-at i)))
                 (cond ((dash? byte)
                        (found-dash i w))
                       ((nix-base32-byte-or-nul? byte)
                        (scan-from (+ i 1) w))
                       (else
                        (not-part-of-hash i w))))
               (finish-buffer i w)))

         (define (not-part-of-hash i w)
           ;; Position I is known to not be within a nix hash that we must
           ;; rewrite.  Therefore, the earliest position where the next hash
           ;; might start is I + 1, and therefore the earliest position of
           ;; the following dash is (+ I 1 HASH-LENGTH).
           (scan-from (+ i 1 hash-length) w))

         (define (found-dash i w)
           ;; We know that there is a dash '-' at position I, and that
           ;; I - W >= HASH-LENGTH.  The immediately preceding bytes *might*
           ;; contain a nix-base32 hash, but that is not yet known.  Here,
           ;; we rule out all but one possible encoding (ASCII, UTF-16,
           ;; UTF-32) by counting how many NULs precede the dash.
           (cond ((not (zero? (byte-at (- i 1))))
                  ;; The dash is *not* preceded by a NUL, therefore it
                  ;; cannot possibly be a UTF-16 or UTF-32 hash.  Proceed
                  ;; to check for an ASCII hash.
                  (found-possible-hash 1 i w))

                 ((not (zero? (byte-at (- i 2))))
                  ;; The dash is preceded by exactly one NUL, therefore it
                  ;; cannot be an ASCII or UTF-32 hash.  Proceed to check
                  ;; for a UTF-16 hash.
                  (if (possible-utf16-hash? buffer i w)
                      (found-possible-hash 2 i w)
                      (not-part-of-hash i w)))

                 (else
                  ;; The dash is preceded by at least two NULs, therefore
                  ;; it cannot be an ASCII or UTF-16 hash.  Proceed to
                  ;; check for a UTF-32 hash.
                  (if (possible-utf32-hash? buffer i w)
                      (found-possible-hash 4 i w)
                      (not-part-of-hash i w)))))

         (define (found-possible-hash char-size i w)
           ;; We know that there is a dash '-' at position I, that
           ;; I - W >= CHAR-SIZE * HASH-LENGTH, and that the only
           ;; possible encoding for the preceding hash is as indicated by
           ;; CHAR-SIZE.  Here we check to see if the given hash is in
           ;; REPLACEMENT-TABLE, and if so, we perform the required
           ;; rewrite.
           (let* ((hash (string-tabulate
                         (lambda (j)
                           (integer->char
                            (byte-at (- i (* char-size
                                             (- hash-length j))))))
                         hash-length))
                  (replacement* (lookup-replacement hash))
                  (replacement (and replacement*
                                    (insert-nuls char-size replacement*))))
             (cond
              ((not replacement)
               (not-part-of-hash i w))
              (else
               ;; 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 w
                               (- i (* char-size hash-length) w))
               ;; Now write the replacement string.
               (put-bytevector output replacement)
               ;; Now compute the new values of W and I and continue.
               (let ((w (+ (- i (* char-size hash-length))
                           (bytevector-length replacement))))
                 (scan-from (+ w hash-length) w))))))

         (define (finish-buffer i w)
           ;; 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 (* 4 HASH-LENGTH) 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.
           (if (> w end)
               (get-bytevector-n! input buffer 0 (- w end))
               (let* ((unwritten  (- end w))
                      (unget-size (if (= end request-size)
                                      (min (* 4 hash-length)
                                           unwritten)
                                      0))
                      (write-size (- unwritten unget-size)))
                 (put-bytevector output buffer w write-size)
                 (unget-bytevector input buffer (+ w write-size)
                                   unget-size)))
           (outer-loop))

         (scan-from hash-length 0))))))

(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