code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@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 union)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:export (union-build

            warn-about-collision

            relative-file-name
            symlink-relative))

;;; Commentary:
;;;
;;; Build a directory that is the union of a set of directories, using
;;; symbolic links.
;;;
;;; Code:

;; This code can be used with the bootstrap Guile, which is Guile 2.0, so
;; provide a compatibility layer.
(cond-expand
  ((and guile-2 (not guile-2.2))
   (define (setvbuf port mode . rest)
     (apply (@ (guile) setvbuf) port
            (match mode
              ('line _IOLBF)
              ('block _IOFBF)
              ('none _IONBF))
            rest)))
  (else #f))

(define (files-in-directory dirname)
  (let ((dir (opendir dirname)))
    (let loop ((files '()))
      (match (readdir dir)
        ((or "." "..")
         (loop files))
        ((? eof-object?)
         (closedir dir)
         (sort files string<?))
        (file
         (loop (cons file files)))))))

(define (file-is-directory? file)
  (match (stat file #f)
    (#f #f)                                       ;maybe a dangling symlink
    (st (eq? 'directory (stat:type st)))))

(define (file=? file1 file2)
  "Return #t if FILE1 and FILE2 are regular files and their contents are
identical, #f otherwise."
  (let ((st1 (stat file1 #f))
        (st2 (stat file2 #f)))
    ;; When deduplication is enabled, identical files share the same inode.
    (and st1 st2
         (or (= (stat:ino st1) (stat:ino st2))
             (and (eq? (stat:type st1) 'regular)
                  (eq? (stat:type st2) 'regular)
                  (= (stat:size st1) (stat:size st2))
                  (call-with-input-file file1
                    (lambda (port1)
                      (call-with-input-file file2
                        (lambda (port2)
                          (define len 8192)
                          (define buf1 (make-bytevector len))
                          (define buf2 (make-bytevector len))
                          (let loop ()
                            (let ((n1 (get-bytevector-n! port1 buf1 0 len))
                                  (n2 (get-bytevector-n! port2 buf2 0 len)))
                              (and (equal? n1 n2)
                                   (or (eof-object? n1)
                                       (loop))))))))))))))

(define %harmless-collisions
  ;; This is a list of files that are known to collide, but for which emitting
  ;; a warning doesn't make sense.  For example, "icon-theme.cache" is
  ;; regenerated by a profile hook which shadows the file provided by
  ;; individual packages, and "gschemas.compiled" is made available to
  ;; applications via 'glib-or-gtk-build-system'.
  '("icon-theme.cache" "gschemas.compiled"))

(define (warn-about-collision files)
  "Handle the collision among FILES by emitting a warning and choosing the
first one of THEM."
  (let ((file (first files)))
    (unless (member (basename file) %harmless-collisions)
      (format (current-error-port)
              "~%warning: collision encountered:~%~{  ~a~%~}"
              files)
      (format (current-error-port) "warning: choosing ~a~%" file))
    file))

(define* (union-build output inputs
                      #:key (log-port (current-error-port))
                      (create-all-directories? #f)
                      (symlink symlink)
                      (resolve-collision warn-about-collision))
  "Build in the OUTPUT directory a symlink tree that is the union of all the
INPUTS, using SYMLINK to create symlinks.  As a special case, if
CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
make sure the caller can modify them later.

When two or more regular files collide, call RESOLVE-COLLISION with the list
of colliding files and use the one that it returns; or, if RESOLVE-COLLISION
returns #f, skip the faulty file altogether."

  (define (symlink* input output)
    (format log-port "`~a' ~~> `~a'~%" input output)
    (symlink input output))

  (define (resolve-collisions output dirs files)
    (cond ((null? dirs)
           ;; The inputs are all files.
           (match (resolve-collision files)
             (#f #f)
             ((? string? file)
              (symlink* file output))))

          (else
           ;; The inputs are a mixture of files and directories
           (error "union-build: collision between file and directories"
                  `((files ,files) (dirs ,dirs))))))

  (define (union output inputs)
    (match inputs
      ((input)
       ;; There's only one input, so just make a link unless
       ;; create-all-directories?.
       (if (and create-all-directories? (file-is-directory? input))
           (union-of-directories output inputs)
           (symlink* input output)))
      (_
       (call-with-values (lambda () (partition file-is-directory? inputs))
         (match-lambda*
           ((dirs ())
            ;; All inputs are directories.
            (union-of-directories output dirs))

           ((() (file (? (cut file=? <> file)) ...))
            ;; There are no directories, and all files have the same contents,
            ;; so there's no conflict.
            (symlink* file output))

           ((dirs files)
            (resolve-collisions output dirs files)))))))

  (define (union-of-directories output dirs)
    ;; Create a new directory where we will merge the input directories.
    (mkdir output)

    ;; Build a hash table mapping each file to a list of input
    ;; directories containing that file.
    (let ((table (make-hash-table)))

      (define (add-to-table! file dir)
        (hash-set! table file (cons dir (hash-ref table file '()))))

      ;; Populate the table.
      (for-each (lambda (dir)
                  (for-each (cut add-to-table! <> dir)
                            (files-in-directory dir)))
                dirs)

      ;; Now iterate over the table and recursively
      ;; perform a union for each entry.
      (hash-for-each (lambda (file dirs-with-file)
                       (union (string-append output "/" file)
                              (map (cut string-append <> "/" file)
                                   (reverse dirs-with-file))))
                     table)))

  (setvbuf (current-output-port) 'line)
  (setvbuf (current-error-port) 'line)
  (when (file-port? log-port)
    (setvbuf log-port 'line))

  (union-of-directories output (delete-duplicates inputs)))

;;;
;;; Relative symlinks.
;;;

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

(define (relative-file-name reference file)
  "Given REFERENCE and FILE, both of which are absolute file names, return the
file name of FILE relative to REFERENCE.

  (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
  => \"../bin/bar\"

Note that this is from a purely lexical standpoint; conversely, \"..\" is
*not* resolved lexically on POSIX in the presence of symlinks."
  (if (and (string-prefix? "/" file) (string-prefix? "/" reference))
      (let loop ((reference (string-tokenize reference %not-slash))
                 (file      (string-tokenize file %not-slash)))
        (define (finish)
          (string-join (append (make-list (length reference) "..") file)
                       "/"))

        (match reference
          (()
           (finish))
          ((head . tail)
           (match file
             (()
              (finish))
             ((head* . tail*)
              (if (string=? head head*)
                  (loop tail tail*)
                  (finish)))))))
      file))

(define (symlink-relative old new)
  "Assuming both OLD and NEW are absolute file names, make NEW a symlink to
OLD, but using a relative file name."
  (symlink (relative-file-name (dirname new) old)
           new))

;;; union.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-60)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:re-export (alist-cons
               alist-delete

               ;; Note: Re-export 'delete' to allow for proper syntax matching
               ;; in 'modify-phases' forms.  See
               ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
               delete)
  #:export (%store-directory
            store-file-name?
            strip-store-file-name
            package-name->name+version
            parallel-job-count

            directory-exists?
            executable-file?
            symbolic-link?
            call-with-ascii-input-file
            elf-file?
            ar-file?
            gzip-file?
            reset-gzip-timestamp
            with-directory-excursion
            mkdir-p
            install-file
            make-file-writable
            copy-recursively
            delete-file-recursively
            file-name-predicate
            find-files
            false-if-file-not-found

            search-path-as-list
            set-path-environment-variable
            search-path-as-string->list
            list->search-path-as-string
            which

            every*
            alist-cons-before
            alist-cons-after
            alist-replace
            modify-phases

            with-atomic-file-replacement
            substitute
            substitute*
            dump-port
            set-file-time
            patch-shebang
            patch-makefile-SHELL
            patch-/usr/bin/file
            fold-port-matches
            remove-store-references
            wrapper?
            wrap-program
            wrap-script

            wrap-error?
            wrap-error-program
            wrap-error-type

            invoke
            invoke-error?
            invoke-error-program
            invoke-error-arguments
            invoke-error-exit-status
            invoke-error-term-signal
            invoke-error-stop-signal
            report-invoke-error

            invoke/quiet

            make-desktop-entry-file

            locale-category->string))

;;;
;;; Guile 2.0 compatibility later.
;;;

;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.
(cond-expand
  ((and guile-2 (not guile-2.2))
   (define (setvbuf port mode . rest)
     (apply (@ (guile) setvbuf) port
            (match mode
              ('line _IOLBF)
              ('block _IOFBF)
              ('none _IONBF)
              (_ mode))                           ;an _IO* integer
            rest))

   (module-replace! (current-module) '(setvbuf)))
  (else #f))

;;;
;;; Directories.
;;;

(define (%store-directory)
  "Return the directory name of the store."
  (or (getenv "NIX_STORE")
      "/gnu/store"))

(define (store-file-name? file)
  "Return true if FILE is in the store."
  (string-prefix? (%store-directory) file))

(define (strip-store-file-name file)
  "Strip the '/gnu/store' and hash from FILE, a store file name.  The result
is typically a \"PACKAGE-VERSION\" string."
  (string-drop file
               (+ 34 (string-length (%store-directory)))))

(define (package-name->name+version name)
  "Given NAME, a package name like \"foo-0.9.1b\", return two values:
\"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
#f are returned.  The first hyphen followed by a digit is considered to
introduce the version part."
  ;; See also `DrvName' in Nix.

  (define number?
    (cut char-set-contains? char-set:digit <>))

  (let loop ((chars   (string->list name))
             (prefix '()))
    (match chars
      (()
       (values name #f))
      ((#\- (? number? n) rest ...)
       (values (list->string (reverse prefix))
               (list->string (cons n rest))))
      ((head tail ...)
       (loop tail (cons head prefix))))))

(define parallel-job-count
  ;; Number of processes to be passed next to GNU Make's `-j' argument.
  (make-parameter
   (match (getenv "NIX_BUILD_CORES")              ;set by the daemon
     (#f  1)
     ("0" (current-processor-count))
     (x   (or (string->number x) 1)))))

(define (directory-exists? dir)
  "Return #t if DIR exists and is a directory."
  (let ((s (stat dir #f)))
    (and s
         (eq? 'directory (stat:type s)))))

(define (executable-file? file)
  "Return #t if FILE exists and is executable."
  (let ((s (stat file #f)))
    (and s
         (not (zero? (logand (stat:mode s) #o100))))))

(define (symbolic-link? file)
  "Return #t if FILE is a symbolic link (aka. \"symlink\".)"
  (eq? (stat:type (lstat file)) 'symlink))

(define (call-with-ascii-input-file file proc)
  "Open FILE as an ASCII or binary file, and pass the resulting port to
PROC.  FILE is closed when PROC's dynamic extent is left.  Return the
return values of applying PROC to the port."
  (let ((port (with-fluids ((%default-port-encoding #f))
                ;; Use "b" so that `open-file' ignores `coding:' cookies.
                (open-file file "rb"))))
    (dynamic-wind
      (lambda ()
        #t)
      (lambda ()
        (proc port))
      (lambda ()
        (close-input-port port)))))

(define (file-header-match header)
  "Return a procedure that returns true when its argument is a file starting
with the bytes in HEADER, a bytevector."
  (define len
    (bytevector-length header))

  (lambda (file)
    "Return true if FILE starts with the right magic bytes."
    (define (get-header)
      (call-with-input-file file
        (lambda (port)
          (get-bytevector-n port len))
        #:binary #t #:guess-encoding #f))

    (catch 'system-error
      (lambda ()
        (equal? (get-header) header))
      (lambda args
        (if (= EISDIR (system-error-errno args))
            #f                                    ;FILE is a directory
            (apply throw args))))))

(define %elf-magic-bytes
  ;; Magic bytes of ELF files.  See <elf.h>.
  (u8-list->bytevector (map char->integer (string->list "\x7FELF"))))

(define elf-file?
  (file-header-match %elf-magic-bytes))

(define %ar-magic-bytes
  ;; Magic bytes of archives created by 'ar'.  See <ar.h>.
  (u8-list->bytevector (map char->integer (string->list "!<arch>\n"))))

(define ar-file?
  (file-header-match %ar-magic-bytes))

(define %gzip-magic-bytes
  ;; Magic bytes of gzip file.  Beware, it's a small header so there could be
  ;; false positives.
  #vu8(#x1f #x8b))

(define gzip-file?
  (file-header-match %gzip-magic-bytes))

(define* (reset-gzip-timestamp file #:key (keep-mtime? #t))
  "If FILE is a gzip file, reset its embedded timestamp (as with 'gzip
--no-name') and return true.  Otherwise return #f.  When KEEP-MTIME? is true,
preserve FILE's modification time."
  (let ((stat (stat file))
        (port (open file O_RDWR)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (and (= 4 (seek port 4 SEEK_SET))
             (put-bytevector port #vu8(0 0 0 0))))
      (lambda ()
        (close-port port)
        (set-file-time file stat)))))

(define-syntax-rule (with-directory-excursion dir body ...)
  "Run BODY with DIR as the process's current directory."
  (let ((init (getcwd)))
   (dynamic-wind
     (lambda ()
       (chdir dir))
     (lambda ()
       body ...)
     (lambda ()
       (chdir init)))))

(define (mkdir-p dir)
  "Create directory DIR and all its ancestors."
  (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)
             (loop tail path))
           (lambda args
             (if (= EEXIST (system-error-errno args))
                 (loop tail path)
                 (apply throw args))))))
      (() #t))))

(define (install-file file directory)
  "Create DIRECTORY if it does not exist and copy FILE in there under the same
name."
  (mkdir-p directory)
  (copy-file file (string-append directory "/" (basename file))))

(define (make-file-writable file)
  "Make FILE writable for its owner."
  (let ((stat (lstat file)))                      ;XXX: symlinks
    (chmod file (logior #o600 (stat:perms stat)))))

(define* (copy-recursively source destination
                           #:key
                           (log (current-output-port))
                           (follow-symlinks? #f)
                           keep-mtime?)
  "Copy SOURCE directory to DESTINATION.  Follow symlinks if FOLLOW-SYMLINKS?
is true; otherwise, just preserve them.  When KEEP-MTIME? is true, keep the
modification time of the files in SOURCE on those of DESTINATION.  Write
verbose output to the LOG port."
  (define strip-source
    (let ((len (string-length source)))
      (lambda (file)
        (substring file len))))

  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (let ((dest (string-append destination
                                                 (strip-source file))))
                        (format log "`~a' -> `~a'~%" file dest)
                        (case (stat:type stat)
                          ((symlink)
                           (let ((target (readlink file)))
                             (symlink target dest)))
                          (else
                           (copy-file file dest)
                           (when keep-mtime?
                             (set-file-time dest stat))))))
                    (lambda (dir stat result)     ; down
                      (let ((target (string-append destination
                                                   (strip-source dir))))
                        (mkdir-p target)
                        (when keep-mtime?
                          (set-file-time target stat))))
                    (lambda (dir stat result)     ; up
                      result)
                    (const #t)                    ; skip
                    (lambda (file stat errno result)
                      (format (current-error-port) "i/o error: ~a: ~a~%"
                              file (strerror errno))
                      #f)
                    #t
                    source

                    (if follow-symlinks?
                        stat
                        lstat)))

(define* (delete-file-recursively dir
                                  #:key follow-mounts?)
  "Delete DIR recursively, like `rm -rf', without following symlinks.  Don't
follow mount points either, unless FOLLOW-MOUNTS? is true.  Report but ignore
errors."
  (let ((dev (stat:dev (lstat dir))))
    (file-system-fold (lambda (dir stat result)    ; enter?
                        (or follow-mounts?
                            (= dev (stat:dev stat))))
                      (lambda (file stat result)   ; leaf
                        (delete-file file))
                      (const #t)                   ; down
                      (lambda (dir stat result)    ; up
                        (rmdir dir))
                      (const #t)                   ; skip
                      (lambda (file stat errno result)
                        (format (current-error-port)
                                "warning: failed to delete ~a: ~a~%"
                                file (strerror errno)))
                      #t
                      dir

                      ;; Don't follow symlinks.
                      lstat)))

(define (file-name-predicate regexp)
  "Return a predicate that returns true when passed a file name whose base
name matches REGEXP."
  (let ((file-rx (if (regexp? regexp)
                     regexp
                     (make-regexp regexp))))
    (lambda (file stat)
      (regexp-exec file-rx (basename file)))))

(define* (find-files dir #:optional (pred (const #t))
                     #:key (stat lstat)
                     directories?
                     fail-on-error?)
  "Return the lexicographically sorted list of files under DIR for which PRED
returns true.  PRED is passed two arguments: the absolute file name, and its
stat buffer; the default predicate always returns true.  PRED can also be a
regular expression, in which case it is equivalent to (file-name-predicate
PRED).  STAT is used to obtain file information; using 'lstat' means that
symlinks are not followed.  If DIRECTORIES? is true, then directories will
also be included.  If FAIL-ON-ERROR? is true, raise an exception upon error."
  (let ((pred (if (procedure? pred)
                  pred
                  (file-name-predicate pred))))
    ;; Sort the result to get deterministic results.
    (sort (file-system-fold (const #t)
                            (lambda (file stat result) ; leaf
                              (if (pred file stat)
                                  (cons file result)
                                  result))
                            (lambda (dir stat result) ; down
                              (if (and directories?
                                       (pred dir stat))
                                  (cons dir result)
                                  result))
                            (lambda (dir stat result) ; up
                              result)
                            (lambda (file stat result) ; skip
                              result)
                            (lambda (file stat errno result)
                              (format (current-error-port) "find-files: ~a: ~a~%"
                                      file (strerror errno))
                              (when fail-on-error?
                                (error "find-files failed"))
                              result)
                            '()
                            dir
                            stat)
          string<?)))

(define-syntax-rule (false-if-file-not-found exp)
  "Evaluate EXP but return #f if it raises to 'system-error with ENOENT."
  (catch 'system-error
    (lambda () exp)
    (lambda args
      (if (= ENOENT (system-error-errno args))
          #f
          (apply throw args)))))

;;;
;;; Search paths.
;;;

(define* (search-path-as-list files input-dirs
                              #:key (type 'directory) pattern)
  "Return the list of directories among FILES of the given TYPE (a symbol as
returned by 'stat:type') that exist in INPUT-DIRS.  Example:

  (search-path-as-list '(\"share/emacs/site-lisp\" \"share/emacs/24.1\")
                       (list \"/package1\" \"/package2\" \"/package3\"))
  => (\"/package1/share/emacs/site-lisp\"
      \"/package3/share/emacs/site-lisp\")

When PATTERN is true, it is a regular expression denoting file names to look
for under the directories designated by FILES.  For example:

  (search-path-as-list '(\"xml\") (list docbook-xml docbook-xsl)
                       #:type 'regular
                       #:pattern \"^catalog\\\\.xml$\")
  => (\"/…/xml/dtd/docbook/catalog.xml\"
      \"/…/xml/xsl/docbook-xsl-1.78.1/catalog.xml\")
"
  (append-map (lambda (input)
                (append-map (lambda (file)
                              (let ((file (string-append input "/" file)))
                                (if pattern
                                    (find-files file (lambda (file stat)
                                                       (and stat
                                                            (eq? type (stat:type stat))
                                                            ((file-name-predicate pattern) file stat)))
                                                #:stat stat
                                                #:directories? #t)
                                    (let ((stat (stat file #f)))
                                      (if (and stat (eq? type (stat:type stat)))
                                          (list file)
                                          '())))))
                            files))
              (delete-duplicates input-dirs)))

(define (list->search-path-as-string lst separator)
  (if separator
      (string-join lst separator)
      (match lst
        ((head rest ...) head)
        (() ""))))

(define* (search-path-as-string->list path #:optional (separator #\:))
  (if separator
      (string-tokenize path
                       (char-set-complement (char-set separator)))
      (list path)))

(define* (set-path-environment-variable env-var files input-dirs
                                        #:key
                                        (separator ":")
                                        (type 'directory)
                                        pattern)
  "Look for each of FILES of the given TYPE (a symbol as returned by
'stat:type') in INPUT-DIRS.  Set ENV-VAR to a SEPARATOR-separated path
accordingly.  Example:

  (set-path-environment-variable \"PKG_CONFIG\"
                                 '(\"lib/pkgconfig\")
                                 (list package1 package2))

When PATTERN is not #f, it must be a regular expression (really a string)
denoting file names to look for under the directories designated by FILES:

  (set-path-environment-variable \"XML_CATALOG_FILES\"
                                 '(\"xml\")
                                 (list docbook-xml docbook-xsl)
                                 #:type 'regular
                                 #:pattern \"^catalog\\\\.xml$\")
"
  (let* ((path  (search-path-as-list files input-dirs
                                     #:type type
                                     #:pattern pattern))
         (value (list->search-path-as-string path separator)))
    (if (string-null? value)
        (begin
          ;; Never set ENV-VAR to an empty string because often, the empty
          ;; string is equivalent to ".".  This is the case for
          ;; GUILE_LOAD_PATH in Guile 2.0, for instance.
          (unsetenv env-var)
          (format #t "environment variable `~a' unset~%" env-var))
        (begin
          (setenv env-var value)
          (format #t "environment variable `~a' set to `~a'~%"
                  env-var value)))))

(define (which program)
  "Return the complete file name for PROGRAM as found in $PATH, or #f if
PROGRAM could not be found."
  (search-path (search-path-as-string->list (getenv "PATH"))
               program))

;;;
;;; Phases.
;;;
;;; In (guix build gnu-build-system), there are separate phases (configure,
;;; build, test, install).  They are represented as a list of name/procedure
;;; pairs.  The following procedures make it easy to change the list of
;;; phases.
;;;

(define (every* pred lst)
  "This is like 'every', but process all the elements of LST instead of
stopping as soon as PRED returns false.  This is useful when PRED has side
effects, such as displaying warnings or error messages."
  (let loop ((lst    lst)
             (result #t))
    (match lst
      (()
       result)
      ((head . tail)
       (loop tail (and (pred head) result))))))

(define* (alist-cons-before reference key value alist
                            #:optional (key=? equal?))
  "Insert the KEY/VALUE pair before the first occurrence of a pair whose key
is REFERENCE in ALIST.  Use KEY=? to compare keys."
  (let-values (((before after)
                (break (match-lambda
                        ((k . _)
                         (key=? k reference)))
                       alist)))
    (append before (alist-cons key value after))))

(define* (alist-cons-after reference key value alist
                           #:optional (key=? equal?))
  "Insert the KEY/VALUE pair after the first occurrence of a pair whose key
is REFERENCE in ALIST.  Use KEY=? to compare keys."
  (let-values (((before after)
                (break (match-lambda
                        ((k . _)
                         (key=? k reference)))
                       alist)))
    (match after
      ((reference after ...)
       (append before (cons* reference `(,key . ,value) after)))
      (()
       (append before `((,key . ,value)))))))

(define* (alist-replace key value alist #:optional (key=? equal?))
  "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair.
An error is raised when no such pair exists."
  (let-values (((before after)
                (break (match-lambda
                        ((k . _)
                         (key=? k key)))
                       alist)))
    (match after
      ((_ after ...)
       (append before (alist-cons key value after))))))

(define-syntax-rule (modify-phases phases mod-spec ...)
  "Modify PHASES sequentially as per each MOD-SPEC, which may have one of the
following forms:

  (delete <old-phase-name>)
  (replace <old-phase-name> <new-phase>)
  (add-before <old-phase-name> <new-phase-name> <new-phase>)
  (add-after <old-phase-name> <new-phase-name> <new-phase>)

Where every <*-phase-name> is an expression evaluating to a symbol, and
<new-phase> an expression evaluating to a procedure."
  (let* ((phases* phases)
         (phases* (%modify-phases phases* mod-spec))
         ...)
    phases*))

(define-syntax %modify-phases
  (syntax-rules (delete replace add-before add-after)
    ((_ phases (delete old-phase-name))
     (alist-delete old-phase-name phases))
    ((_ phases (replace old-phase-name new-phase))
     (alist-replace old-phase-name new-phase phases))
    ((_ phases (add-before old-phase-name new-phase-name new-phase))
     (alist-cons-before old-phase-name new-phase-name new-phase phases))
    ((_ phases (add-after old-phase-name new-phase-name new-phase))
     (alist-cons-after old-phase-name new-phase-name new-phase phases))))

;;;
;;; Program invocation.
;;;

(define-condition-type &invoke-error &error
  invoke-error?
  (program      invoke-error-program)
  (arguments    invoke-error-arguments)
  (exit-status  invoke-error-exit-status)
  (term-signal  invoke-error-term-signal)
  (stop-signal  invoke-error-stop-signal))

(define (invoke program . args)
  "Invoke PROGRAM with the given ARGS.  Raise an exception
if the exit code is non-zero; otherwise return #t."
  (let ((code (apply system* program args)))
    (unless (zero? code)
      (raise (condition (&invoke-error
                         (program program)
                         (arguments args)
                         (exit-status (status:exit-val code))
                         (term-signal (status:term-sig code))
                         (stop-signal (status:stop-sig code))))))
    #t))

(define* (report-invoke-error c #:optional (port (current-error-port)))
  "Report to PORT about C, an '&invoke-error' condition, in a human-friendly
way."
  (format port "command~{ ~s~} failed with ~:[signal~;status~] ~a~%"
          (cons (invoke-error-program c)
                (invoke-error-arguments c))
          (invoke-error-exit-status c)
          (or (invoke-error-exit-status c)
              (invoke-error-term-signal c)
              (invoke-error-stop-signal c))))

(define (open-pipe-with-stderr program . args)
  "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
both its standard output and standard error to the pipe.  Return two value:
the pipe to read PROGRAM's data from, and the PID of the child process running
PROGRAM."
  ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
  ;; we need to roll our own.
  (match (pipe)
    ((input .  output)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close-port input)
            (dup2 (fileno output) 1)
            (dup2 (fileno output) 2)
            (apply execlp program program args))
          (lambda ()
            (primitive-exit 127))))
       (pid
        (close-port output)
        (values input pid))))))

(define (invoke/quiet program . args)
  "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
error.  If PROGRAM succeeds, print nothing and return the unspecified value;
otherwise, raise a '&message' error condition that includes the status code
and the output of PROGRAM."
  (let-values (((pipe pid)
                (apply open-pipe-with-stderr program args)))
    (let loop ((lines '()))
      (match (read-line pipe)
        ((? eof-object?)
         (close-port pipe)
         (match (waitpid pid)
           ((_ . status)
            (unless (zero? status)
              (let-syntax ((G_ (syntax-rules ()   ;for xgettext
                                 ((_ str) str))))
                (raise (condition
                        (&message
                         (message (format #f (G_ "'~a~{ ~a~}' exited \
with status ~a; output follows:~%~%~{  ~a~%~}")
                                          program args
                                          (or (status:exit-val status)
                                              status)
                                          (reverse lines)))))))))))
        (line
         (loop (cons line lines)))))))

;;;
;;; Text substitution (aka. sed).
;;;

(define (with-atomic-file-replacement file proc)
  "Call PROC with two arguments: an input port for FILE, and an output
port for the file that is going to replace FILE.  Upon success, FILE is
atomically replaced by what has been written to the output port, and
PROC's result is returned."
  (let* ((template (string-append file ".XXXXXX"))
         (out      (mkstemp! template))
         (mode     (stat:mode (stat file))))
    (with-throw-handler #t
      (lambda ()
        (call-with-input-file file
          (lambda (in)
            (let ((result (proc in out)))
              (close out)
              (chmod template mode)
              (rename-file template file)
              result))))
      (lambda (key . args)
        (false-if-exception (delete-file template))))))

(define (substitute file pattern+procs)
  "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs.  For each
line of FILE, and for each PATTERN that it matches, call the corresponding
PROC as (PROC LINE MATCHES); PROC must return the line that will be written as
a substitution of the original line.  Be careful about using '$' to match the
end of a line; by itself it won't match the terminating newline of a line."
  (let ((rx+proc  (map (match-lambda
                        (((? regexp? pattern) . proc)
                         (cons pattern proc))
                        ((pattern . proc)
                         (cons (make-regexp pattern regexp/extended)
                               proc)))
                       pattern+procs)))
    (with-atomic-file-replacement file
      (lambda (in out)
        (let loop ((line (read-line in 'concat)))
          (if (eof-object? line)
              #t
              (let ((line (fold (lambda (r+p line)
                                  (match r+p
                                    ((regexp . proc)
                                     (match (list-matches regexp line)
                                       ((and m+ (_ _ ...))
                                        (proc line m+))
                                       (_ line)))))
                                line
                                rx+proc)))
                (display line out)
                (loop (read-line in 'concat)))))))))

(define-syntax let-matches
  ;; Helper macro for `substitute*'.
  (syntax-rules (_)
    ((let-matches index match (_ vars ...) body ...)
     (let-matches (+ 1 index) match (vars ...)
                  body ...))
    ((let-matches index match (var vars ...) body ...)
     (let ((var (match:substring match index)))
       (let-matches (+ 1 index) match (vars ...)
                    body ...)))
    ((let-matches index match () body ...)
     (begin body ...))))

(define-syntax substitute*
  (syntax-rules ()
    "Substitute REGEXP in FILE by the string returned by BODY.  BODY is
evaluated with each MATCH-VAR bound to the corresponding positional regexp
sub-expression.  For example:

  (substitute* file
     ((\"hello\")
      \"good morning\\n\")
     ((\"foo([a-z]+)bar(.*)$\" all letters end)
      (string-append \"baz\" letter end)))

Here, anytime a line of FILE contains \"hello\", it is replaced by \"good
morning\".  Anytime a line of FILE matches the second regexp, ALL is bound to
the complete match, LETTERS is bound to the first sub-expression, and END is
bound to the last one.

When one of the MATCH-VAR is `_', no variable is bound to the corresponding
match substring.

Alternatively, FILE may be a list of file names, in which case they are
all subject to the substitutions.

Be careful about using '$' to match the end of a line; by itself it won't
match the terminating newline of a line."
    ((substitute* file ((regexp match-var ...) body ...) ...)
     (let ()
       (define (substitute-one-file file-name)
         (substitute
          file-name
          (list (cons regexp
                      (lambda (l m+)
                        ;; Iterate over matches M+ and return the
                        ;; modified line based on L.
                        (let loop ((m* m+)  ; matches
                                   (o  0)   ; offset in L
                                   (r  '())) ; result
                          (match m*
                            (()
                             (let ((r (cons (substring l o) r)))
                               (string-concatenate-reverse r)))
                            ((m . rest)
                             (let-matches 0 m (match-var ...)
                               (loop rest
                                     (match:end m)
                                     (cons*
                                      (begin body ...)
                                      (substring l o (match:start m))
                                      r))))))))
                ...)))

       (match file
         ((files (... ...))
          (for-each substitute-one-file files))
         ((? string? f)
          (substitute-one-file f)))))))

;;;
;;; Patching shebangs---e.g., /bin/sh -> /gnu/store/xyz...-bash/bin/sh.
;;;

(define* (dump-port in out
                    #:key (buffer-size 16384)
                    (progress (lambda (t k) (k))))
  "Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes.  Call PROGRESS at the beginning and after each successful
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
transferred and the continuation of the transfer as a thunk."
  (define buffer
    (make-bytevector buffer-size))

  (define (loop total bytes)
    (or (eof-object? bytes)
        (let ((total (+ total bytes)))
          (put-bytevector out buffer 0 bytes)
          (progress total
                    (lambda ()
                      (loop total
                            (get-bytevector-n! in buffer 0 buffer-size)))))))

  ;; Make sure PROGRESS is called when we start so that it can measure
  ;; throughput.
  (progress 0
            (lambda ()
              (loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))

(define (set-file-time file stat)
  "Set the atime/mtime of FILE to that specified by STAT."
  (utime file
         (stat:atime stat)
         (stat:mtime stat)
         (stat:atimensec stat)
         (stat:mtimensec stat)))

(define (get-char* p)
  ;; We call it `get-char', but that's really a binary version
  ;; thereof.  (The real `get-char' cannot be used here because our
  ;; bootstrap Guile is hacked to always use UTF-8.)
  (match (get-u8 p)
    ((? integer? x) (integer->char x))
    (x x)))

(define patch-shebang
  (let ((shebang-rx (make-regexp "^[[:blank:]]*(/[[:graph:]]+)[[:blank:]]*([[:graph:]]*)(.*)$")))
    (lambda* (file
              #:optional
              (path (search-path-as-string->list (getenv "PATH")))
              #:key (keep-mtime? #t))
      "Replace the #! interpreter file name in FILE by a valid one found in
PATH, when FILE actually starts with a shebang.  Return #t when FILE was
patched, #f otherwise.  When KEEP-MTIME? is true, the atime/mtime of
FILE are kept unchanged."
      (define (patch p interpreter rest-of-line)
        (let* ((template (string-append file ".XXXXXX"))
               (out      (mkstemp! template))
               (st       (stat file))
               (mode     (stat:mode st)))
          (with-throw-handler #t
            (lambda ()
              (format out "#!~a~a~%"
                      interpreter rest-of-line)
              (dump-port p out)
              (close out)
              (chmod template mode)
              (rename-file template file)
              (when keep-mtime?
                (set-file-time file st))
              #t)
            (lambda (key . args)
              (format (current-error-port)
                      "patch-shebang: ~a: error: ~a ~s~%"
                      file key args)
              (false-if-exception (delete-file template))
              #f))))

      (call-with-ascii-input-file file
        (lambda (p)
          (and (eq? #\# (get-char* p))
               (eq? #\! (get-char* p))
               (let ((line (false-if-exception (read-line p))))
                 (and=> (and line (regexp-exec shebang-rx line))
                        (lambda (m)
                          (let* ((interp (match:substring m 1))
                                 (arg1 (match:substring m 2))
                                 (rest (match:substring m 3))
                                 (has-env (string-suffix? "/env" interp))
                                 (cmd (if has-env arg1 (basename interp)))
                                 (bin (search-path path cmd)))
                            (if bin
                                (if (string=? bin interp)
                                    #f            ; nothing to do
                                    (if has-env
                                        (begin
                                          (format (current-error-port)
                                                  "patch-shebang: ~a: changing `~a' to `~a'~%"
                                                  file (string-append interp " " arg1) bin)
                                          (patch p bin rest))
                                      (begin
                                        (format (current-error-port)
                                                "patch-shebang: ~a: changing `~a' to `~a'~%"
                                                file interp bin)
                                        (patch p bin
                                               (if (string-null? arg1)
                                                   ""
                                                   (string-append " " arg1 rest))))))
                                (begin
                                  (format (current-error-port)
                                          "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
                                          file (basename cmd))
                                  #f))))))))))))

(define* (patch-makefile-SHELL file #:key (keep-mtime? #t))
  "Patch the `SHELL' variable in FILE, which is supposedly a makefile.
When KEEP-MTIME? is true, the atime/mtime of FILE are kept unchanged."

  ;; For instance, Gettext-generated po/Makefile.in.in do not honor $SHELL.

  ;; XXX: Unlike with `patch-shebang', FILE is always touched.

  (define (find-shell name)
    (let ((shell (which name)))
      (unless shell
        (format (current-error-port)
                "patch-makefile-SHELL: warning: no binary for shell `~a' found in $PATH~%"
                name))
      shell))

  (let ((st (stat file)))
    ;; Consider FILE is using an 8-bit encoding to avoid errors.
    (with-fluids ((%default-port-encoding #f))
      (substitute* file
        (("^ *SHELL[[:blank:]]*:?=[[:blank:]]*([[:graph:]]*/)([[:graph:]]+)(.*)$"
          _ dir shell args)
         (let* ((old (string-append dir shell))
                (new (or (find-shell shell) old)))
           (unless (string=? new old)
             (format (current-error-port)
                     "patch-makefile-SHELL: ~a: changing `SHELL' from `~a' to `~a'~%"
                     file old new))
           (string-append "SHELL = " new args)))))

   (when keep-mtime?
     (set-file-time file st))))

(define* (patch-/usr/bin/file file
                              #:key
                              (file-command (which "file"))
                              (keep-mtime? #t))
  "Patch occurrences of \"/usr/bin/file\" in FILE, replacing them with
FILE-COMMAND.  When KEEP-MTIME? is true, keep FILE's modification time
unchanged."
  (if (not file-command)
      (format (current-error-port)
              "patch-/usr/bin/file: warning: \
no replacement 'file' command, doing nothing~%")
      (let ((st (stat file)))
        ;; Consider FILE is using an 8-bit encoding to avoid errors.
        (with-fluids ((%default-port-encoding #f))
          (substitute* file
            (("/usr/bin/file")
             (begin
               (format (current-error-port)
                       "patch-/usr/bin/file: ~a: changing `~a' to `~a'~%"
                       file "/usr/bin/file" file-command)
               file-command))))

        (when keep-mtime?
          (set-file-time file st)))))

(define* (fold-port-matches proc init pattern port
                            #:optional (unmatched (lambda (_ r) r)))
  "Read from PORT character-by-character; for each match against
PATTERN, call (PROC MATCH RESULT), where RESULT is seeded with INIT.
PATTERN is a list of SRFI-14 char-sets.  Call (UNMATCHED CHAR RESULT)
for each unmatched character."
  (define initial-pattern
    ;; The poor developer's regexp.
    (if (string? pattern)
        (map char-set (string->list pattern))
        pattern))

  ;; Note: we're not really striving for performance here...
  (let loop ((chars   '())
             (pattern initial-pattern)
             (matched '())
             (result  init))
    (cond ((null? chars)
           (loop (list (get-char* port))
                 pattern
                 matched
                 result))
          ((null? pattern)
           (loop chars
                 initial-pattern
                 '()
                 (proc (list->string (reverse matched)) result)))
          ((eof-object? (car chars))
           (fold-right unmatched result matched))
          ((char-set-contains? (car pattern) (car chars))
           (loop (cdr chars)
                 (cdr pattern)
                 (cons (car chars) matched)
                 result))
          ((null? matched)                        ; common case
           (loop (cdr chars)
                 pattern
                 matched
                 (unmatched (car chars) result)))
          (else
           (let ((matched (reverse matched)))
             (loop (append (cdr matched) chars)
                   initial-pattern
                   '()
                   (unmatched (car matched) result)))))))

(define* (remove-store-references file
                                  #:optional (store (%store-directory)))
  "Remove from FILE occurrences of file names in STORE; return #t when
store paths were encountered in FILE, #f otherwise.  This procedure is
known as `nuke-refs' in Nixpkgs."
  (define pattern
    (let ((nix-base32-chars
           '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
             #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
             #\p #\q #\r #\s #\v #\w #\x #\y #\z)))
      `(,@(map char-set (string->list store))
        ,(char-set #\/)
        ,@(make-list 32 (list->char-set nix-base32-chars))
        ,(char-set #\-))))

  (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 store references from `~a'...~%" 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-condition-type &wrap-error &error
  wrap-error?
  (program    wrap-error-program)
  (type       wrap-error-type))

(define (wrapper? prog)
  "Return #t if PROG is a wrapper as produced by 'wrap-program'."
  (and (file-exists? prog)
       (let ((base (basename prog)))
         (and (string-prefix? "." base)
              (string-suffix? "-real" base)))))

(define* (wrap-program prog #:rest vars)
  "Make a wrapper for PROG.  VARS should look like this:

  '(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)

where DELIMITER is optional.  ':' will be used if DELIMITER is not given.

For example, this command:

  (wrap-program \"foo\"
                '(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
                '(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
                                        \"/qux/certs\")))

will copy 'foo' to '.foo-real' and create the file 'foo' with the following
contents:

  #!location/of/bin/bash
  export PATH=\"/gnu/.../bar/bin\"
  export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
  exec -a $0 location/of/.foo-real \"$@\"

This is useful for scripts that expect particular programs to be in $PATH, for
programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
modules in $GUILE_LOAD_PATH, etc.

If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
with definitions for VARS."
  (define wrapped-file
    (string-append (dirname prog) "/." (basename prog) "-real"))

  (define already-wrapped?
    (file-exists? wrapped-file))

  (define (last-line port)
    ;; Return the last line read from PORT and leave PORT's cursor right
    ;; before it.
    (let loop ((previous-line-offset 0)
               (previous-line "")
               (position (seek port 0 SEEK_CUR)))
      (match (read-line port 'concat)
        ((? eof-object?)
         (seek port previous-line-offset SEEK_SET)
         previous-line)
        ((? string? line)
         (loop position line (+ (string-length line) position))))))

  (define (export-variable lst)
    ;; Return a string that exports an environment variable.
    (match lst
      ((var sep '= rest)
       (format #f "export ~a=\"~a\""
               var (string-join rest sep)))
      ((var sep 'prefix rest)
       (format #f "export ~a=\"~a${~a:+~a}$~a\""
               var (string-join rest sep) var sep var))
      ((var sep 'suffix rest)
       (format #f "export ~a=\"$~a${~a+~a}~a\""
               var var var sep (string-join rest sep)))
      ((var '= rest)
       (format #f "export ~a=\"~a\""
               var (string-join rest ":")))
      ((var 'prefix rest)
       (format #f "export ~a=\"~a${~a:+:}$~a\""
               var (string-join rest ":") var var))
      ((var 'suffix rest)
       (format #f "export ~a=\"$~a${~a:+:}~a\""
               var var var (string-join rest ":")))))

  (if already-wrapped?

      ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just
      ;; before the last line.
      (let* ((port (open-file prog "r+"))
             (last (last-line port)))
        (for-each (lambda (var)
                    (display (export-variable var) port)
                    (newline port))
                  vars)
        (display last port)
        (close-port port))

      ;; PROG is not wrapped yet: create a shell script that sets VARS.
      (let ((prog-tmp (string-append wrapped-file "-tmp")))
        (link prog wrapped-file)

        (call-with-output-file prog-tmp
          (lambda (port)
            (format port
                    "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
                    (which "bash")
                    (string-join (map export-variable vars) "\n")
                    (canonicalize-path wrapped-file))))

        (chmod prog-tmp #o755)
        (rename-file prog-tmp prog))))

(define wrap-script
  (let ((interpreter-regex
         (make-regexp
          (string-append "^#! ?(/[^ ]+/bin/("
                         (string-join '("python[^ ]*"
                                        "Rscript"
                                        "perl"
                                        "ruby"
                                        "bash"
                                        "sh") "|")
                         "))( ?.*)")))
        (coding-line-regex
         (make-regexp
          ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)")))
    (lambda* (prog #:key (guile (which "guile")) #:rest vars)
      "Wrap the script PROG such that VARS are set first.  The format of VARS
is the same as in the WRAP-PROGRAM procedure.  This procedure differs from
WRAP-PROGRAM in that it does not create a separate shell script.  Instead,
PROG is modified directly by prepending a Guile script, which is interpreted
as a comment in the script's language.

Special encoding comments as supported by Python are recreated on the second
line.

Note that this procedure can only be used once per file as Guile scripts are
not supported."
      (define update-env
        (match-lambda
          ((var sep '= rest)
           `(setenv ,var ,(string-join rest sep)))
          ((var sep 'prefix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append ,(string-join rest sep)
                                              ,sep current)
                               ,(string-join rest sep)))))
          ((var sep 'suffix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append current ,sep
                                              ,(string-join rest sep))
                               ,(string-join rest sep)))))
          ((var '= rest)
           `(setenv ,var ,(string-join rest ":")))
          ((var 'prefix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append ,(string-join rest ":")
                                              ":" current)
                               ,(string-join rest ":")))))
          ((var 'suffix rest)
           `(let ((current (getenv ,var)))
              (setenv ,var (if current
                               (string-append current ":"
                                              ,(string-join rest ":"))
                               ,(string-join rest ":")))))))
      (let-values (((interpreter args coding-line)
                    (call-with-ascii-input-file prog
                      (lambda (p)
                        (let ((first-match
                               (false-if-exception
                                (regexp-exec interpreter-regex (read-line p)))))
                          (values (and first-match (match:substring first-match 1))
                                  (and first-match (match:substring first-match 3))
                                  (false-if-exception
                                   (and=> (regexp-exec coding-line-regex (read-line p))
                                          (lambda (m) (match:substring m 0))))))))))
        (if interpreter
            (let* ((header (format #f "\
#!~a --no-auto-compile
#!#; ~a
#\\-~s
#\\-~s
"
                                   guile
                                   (or coding-line "Guix wrapper")
                                   (cons 'begin (map update-env
                                                     (match vars
                                                       ((#:guile _ . vars) vars)
                                                       (_ vars))))
                                   `(let ((cl (command-line)))
                                      (apply execl ,interpreter
                                             (car cl)
                                             (cons (car cl)
                                                   (append
                                                    ',(string-split args #\space)
                                                    cl))))))
                   (template (string-append prog ".XXXXXX"))
                   (out      (mkstemp! template))
                   (st       (stat prog))
                   (mode     (stat:mode st)))
              (with-throw-handler #t
                (lambda ()
                  (call-with-ascii-input-file prog
                    (lambda (p)
                      (format out header)
                      (dump-port p out)
                      (close out)
                      (chmod template mode)
                      (rename-file template prog)
                      (set-file-time prog st))))
                (lambda (key . args)
                  (format (current-error-port)
                          "wrap-script: ~a: error: ~a ~s~%"
                          prog key args)
                  (false-if-exception (delete-file template))
                  (raise (condition
                          (&wrap-error (program prog)
                                       (type key))))
                  #f)))
            (raise (condition
                    (&wrap-error (program prog)
                                 (type 'no-interpreter-found)))))))))

(define* (make-desktop-entry-file destination #:key
                                  (type "Application") ; One of "Application", "Link" or "Directory".
                                  (version "1.1")
                                  name
                                  (generic-name name)
                                  (no-display #f)
                                  comment
                                  icon
                                  (hidden #f)
                                  only-show-in
                                  not-show-in
                                  (d-bus-activatable #f)
                                  try-exec
                                  exec
                                  path
                                  (terminal #f)
                                  actions
                                  mime-type
                                  (categories "Application")
                                  implements
                                  keywords
                                  (startup-notify #t)
                                  startup-w-m-class
                                  #:rest all-args)
  "Create a desktop entry file at DESTINATION.
You must specify NAME.

Values can be booleans, numbers, strings or list of strings.

Additionally, locales can be specified with an alist where the key is the
locale.  The #f key specifies the default.  Example:

  #:name '((#f \"I love Guix\") (\"fr\" \"J'aime Guix\"))

produces

  Name=I love Guix
  Name[fr]=J'aime Guix

For a complete description of the format, see the specifications at
https://specifications.freedesktop.org/desktop-entry-spec/desktop-entry-spec-latest.html."
  (define (escape-semicolon s)
    (string-join (string-split s #\;) "\\;"))
  (define* (parse key value #:optional locale)
    (set! value (match value
                  (#t "true")
                  (#f "false")
                  ((?  number? n) n)
                  ((?  string? s) (escape-semicolon s))
                  ((?  list? value)
                   (catch 'wrong-type-arg
                     (lambda () (string-join (map escape-semicolon value) ";"))
                     (lambda args (error "List arguments can only contain strings: ~a" args))))
                  (_ (error "Value must be a boolean, number, string or list of strings"))))
    (format #t "~a=~a~%"
            (if locale
                (format #f "~a[~a]" key locale)
                key)
            value))

  (define key-error-message "This procedure only takes key arguments beside DESTINATION")

  (unless name
    (error "Missing NAME key argument"))
  (unless (member #:type all-args)
    (set! all-args (append (list #:type type) all-args)))
  (mkdir-p (dirname destination))

  (with-output-to-file destination
    (lambda ()
      (format #t "[Desktop Entry]~%")
      (let loop ((args all-args))
        (match args
          (() #t)
          ((_) (error key-error-message))
          ((key value . ...)
           (unless (keyword? key)
             (error key-error-message))
           (set! key
                 (string-join (map string-titlecase
                                   (string-split (symbol->string
                                                  (keyword->symbol key))
                                                 #\-))
                              ""))
           (match value
             (((_ . _) . _)
              (for-each (lambda (locale-subvalue)
                          (parse key
                                 (if (and (list? (cdr locale-subvalue))
                                          (= 1 (length (cdr locale-subvalue))))
                                     ;; Support both proper and improper lists for convenience.
                                     (cadr locale-subvalue)
                                     (cdr locale-subvalue))
                                 (car locale-subvalue)))
                        value))
             (_
              (parse key value)))
           (loop (cddr args))))))))

;;;
;;; Locales.
;;;

(define (locale-category->string category)
  "Return the name of locale category CATEGORY, one of the 'LC_' constants.
If CATEGORY is a bitwise or of several 'LC_' constants, an approximation is
returned."
  (letrec-syntax ((convert (syntax-rules ()
                             ((_)
                              (number->string category))
                             ((_ first rest ...)
                              (if (= first category)
                                  (symbol->string 'first)
                                  (convert rest ...))))))
    (convert LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE
             LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY
             LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE
             LC_TIME)))

;;; Local Variables:
;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;;; eval: (put 'call-with-ascii-input-file 'scheme-indent-function 1)
;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
;;; eval: (put 'let-matches 'scheme-indent-function 3)
;;; eval: (put 'with-atomic-file-replacement 'scheme-indent-function 1)
;;; End:

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 waf-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 ftw)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            waf-build))

;; Commentary:
;;
;; Builder-side code of the standard waf build procedure.
;;
;; Code:

(define (call-waf command params)
  (if (file-exists? "waf")
      (begin
         (format #t "running \"python waf\" with command ~s and parameters ~s~%"
                command params)
         (apply invoke "python" "waf" command params)
         #t)
      (error "no waf found")))

(define* (configure #:key target native-inputs inputs outputs
                    (configure-flags '())
                    #:allow-other-keys)
  "Build a given waf application."
  (let* ((prefix (assoc-ref outputs "out"))
         (flags  `(,(string-append "--prefix=" prefix)
                   ,@configure-flags)))
    (call-waf "configure" flags)))

(define* (build #:rest empty)
  "Build a given waf application."
  (call-waf "build" '()))

(define* (check #:key tests? test-target #:allow-other-keys)
  "Run the test suite of a given waf application."
  (if tests?
    (call-waf test-target '())
    #t))

(define* (install #:key outputs inputs (configure-flags '())
                  #:allow-other-keys)
  "Install a given waf application."
  (let* ((out (assoc-ref outputs "out"))
         (params (append (list (string-append "--prefix=" out))
                         configure-flags)))
        (call-waf "install" params)))

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

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

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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 bzr-download)
  #:use-module (guix gexp)
  #:use-module (guix modules)   ;for 'source-module-closure'
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix store)

  #:export (bzr-reference
            bzr-reference?
            bzr-reference-url
            bzr-reference-revision

            bzr-fetch))

;;; Commentary:
;;;
;;; An <origin> method that fetches a specific revision from a Bazaar
;;; repository.  The repository URL and revision identifier are specified with
;;; a <bzr-reference> object.
;;;
;;; Code:

(define-record-type* <bzr-reference>
  bzr-reference make-bzr-reference
  bzr-reference?
  (url bzr-reference-url)
  (revision bzr-reference-revision))

(define (bzr-package)
  "Return the default Bazaar package."
  (let ((distro (resolve-interface '(gnu packages version-control))))
    (module-ref distro 'bazaar)))

(define* (bzr-fetch ref hash-algo hash
                       #:optional name
                       #:key (system (%current-system)) (guile (default-guile))
                       (bzr (bzr-package)))
  "Return a fixed-output derivation that fetches REF, a <bzr-reference>
object.  The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  (define build
    (with-imported-modules (source-module-closure
                            '((guix build bzr)))
      #~(begin
          (use-modules (guix build bzr))
          (bzr-fetch
           (getenv "bzr url") (getenv "bzr reference") #$output
           #:bzr-command (string-append #+bzr "/bin/bzr")))))

  (mlet %store-monad ((guile (package->derivation guile system)))
    (gexp->derivation (or name "bzr-branch") build
                      ;; Use environment variables and a fixed script name so
                      ;; there's only one script in store for all the
                      ;; downloads.
                      #:script-name "bzr-download"
                      #:env-vars
                      `(("bzr url" . ,(bzr-reference-url ref))
                        ("bzr reference" . ,(bzr-reference-revision ref)))
                      #:leaked-env-vars '("http_proxy" "https_proxy"
                                          "LC_ALL" "LC_MESSAGES" "LANG"
                                          "COLUMNS")
                      #:system system
                      #:local-build? #t  ;don't offload repo branching
                      #:hash-algo hash-algo
                      #:hash hash
                      #:recursive? #t
                      #:guile-for-build guile)))

;;; bzr-download.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 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 cache)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (obsolete?
            delete-file*
            file-expiration-time
            remove-expired-cache-entries
            maybe-remove-expired-cache-entries))

;;; Commentary:
;;;
;;; This module provides tools to manage a simple on-disk cache consisting of
;;; individual files.
;;;
;;; Code:

(define (obsolete? date now ttl)
  "Return #t if DATE is obsolete compared to NOW + TTL seconds."
  (time>? (subtract-duration now (make-time time-duration 0 ttl))
          (make-time time-monotonic 0 date)))

(define (delete-file* file)
  "Like 'delete-file', but does not raise an error when FILE does not exist."
  (catch 'system-error
    (lambda ()
      (delete-file file))
    (lambda args
      (unless (= ENOENT (system-error-errno args))
        (apply throw args)))))

(define* (file-expiration-time ttl #:optional (timestamp stat:atime))
  "Return a procedure that, when passed a file, returns its \"expiration
time\" computed as its timestamp + TTL seconds.  Call TIMESTAMP to obtain the
relevant timestamp from the result of 'stat'."
  (lambda (file)
    (match (stat file #f)
      (#f 0)                       ;FILE may have been deleted in the meantime
      (st (+ (timestamp st) ttl)))))

(define* (remove-expired-cache-entries entries
                                       #:key
                                       (now (current-time time-monotonic))
                                       (entry-expiration
                                        (file-expiration-time 3600))
                                       (delete-entry delete-file*))
  "Given ENTRIES, a list of file names, remove those whose expiration time,
as returned by ENTRY-EXPIRATION, has passed.  Use DELETE-ENTRY to delete
them."
  (for-each (lambda (entry)
              (when (<= (entry-expiration entry) (time-second now))
                (delete-entry entry)))
            entries))

(define* (maybe-remove-expired-cache-entries cache
                                             cache-entries
                                             #:key
                                             (entry-expiration
                                              (file-expiration-time 3600))
                                             (delete-entry delete-file*)
                                             (cleanup-period (* 24 3600)))
  "Remove expired narinfo entries from the cache if deemed necessary.  Call
CACHE-ENTRIES with CACHE to retrieve the list of cache entries.

ENTRY-EXPIRATION must be a procedure that, when passed an entry, returns the
expiration time of that entry in seconds since the Epoch.  DELETE-ENTRY is a
procedure that removes the entry passed as an argument.  Finally,
CLEANUP-PERIOD denotes the minimum time between two cache cleanups."
  (define now
    (current-time time-monotonic))

  (define expiry-file
    (string-append cache "/last-expiry-cleanup"))

  (define last-expiry-date
    (catch 'system-error
      (lambda ()
        (call-with-input-file expiry-file read))
      (const 0)))

  (when (obsolete? last-expiry-date now cleanup-period)
    (remove-expired-cache-entries (cache-entries cache)
                                  #:now now
                                  #:entry-expiration entry-expiration
                                  #:delete-entry delete-entry)
    (call-with-output-file expiry-file
      (cute write (time-second now) <>))))

;;; cache.scm ends here