code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@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 compile)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (system base target)
  #:use-module (system base compile)
  #:use-module (system base message)
  #:use-module (guix modules)
  #:use-module (guix build utils)
  #:use-module (language tree-il optimize)
  #:use-module (language cps optimize)
  #:export (compile-files))

;;; Commentary:
;;;
;;; Support code to compile Guile code as efficiently as possible (with 2.2).
;;;
;;; Code:

(define optimizations-for-level
  (or (and=> (false-if-exception
              (resolve-interface '(system base optimize)))
             (lambda (iface)
               (module-ref iface 'optimizations-for-level))) ;Guile 3.0
      (let ()                                                ;Guile 2.2
        (define %default-optimizations
          ;; Default optimization options (equivalent to -O2 on Guile 2.2).
          (append (tree-il-default-optimization-options)
                  (cps-default-optimization-options)))

        (define %lightweight-optimizations
          ;; Lightweight optimizations (like -O0, but with partial evaluation).
          (let loop ((opts %default-optimizations)
                     (result '()))
            (match opts
              (() (reverse result))
              ((#:partial-eval? _ rest ...)
               (loop rest `(#t #:partial-eval? ,@result)))
              ((kw _ rest ...)
               (loop rest `(#f ,kw ,@result))))))

        (lambda (level)
          (if (<= level 1)
              %lightweight-optimizations
              %default-optimizations)))))

(define (supported-warning-type? type)
  "Return true if TYPE, a symbol, denotes a supported warning type."
  (find (lambda (warning-type)
          (eq? type (warning-type-name warning-type)))
        %warning-types))

(define %warnings
  ;; FIXME: 'format' is missing because it reports "non-literal format
  ;; strings" due to the fact that we use 'G_' instead of '_'.  We'll need
  ;; help from Guile to solve this.
  (let ((optional (lambda (type)
                    (if (supported-warning-type? type)
                        (list type)
                        '()))))
    `(unbound-variable arity-mismatch
      macro-use-before-definition                         ;new in 2.2
      ,@(optional 'shadowed-toplevel))))                  ;new in 2.2.5

(define (optimization-options file)
  "Return the default set of optimizations options for FILE."
  (define (strip-option option lst)
    (let loop ((lst lst)
               (result '()))
      (match lst
        (()
         (reverse result))
        ((kw value rest ...)
         (if (eq? kw option)
             (append (reverse result) rest)
             (loop rest (cons* value kw result)))))))

  (define (override-option option value lst)
    `(,option ,value ,@(strip-option option lst)))

  (cond ((or (string-contains file "gnu/packages/")
             (string-contains file "gnu/tests/"))
         ;; Use '-O1' to have partial evaluation and primitive inlining so we
         ;; can honor the "macro writer's bill of rights".
         (optimizations-for-level 1))
        ((string-contains file "gnu/services/")
         ;; '-O2 -Ono-letrectify' compiles about ~20% faster than '-O2' for
         ;; large files like gnu/services/mail.scm.
         (override-option #:letrectify? #f
                          (optimizations-for-level 2)))
        (else
         (optimizations-for-level 3))))

(define (scm->go file)
  "Strip the \".scm\" suffix from FILE, and append \".go\"."
  (string-append (string-drop-right file 4) ".go"))

(define (relative-file directory file)
  "Return FILE relative to DIRECTORY, if possible."
  (if (string-prefix? (string-append directory "/") file)
      (string-drop file (+ 1 (string-length directory)))
      file))

(define* (load-files directory files
                     #:key
                     (report-load (const #f))
                     (debug-port (%make-void-port "w")))
  "Load FILES, a list of relative file names, from DIRECTORY."
  (define total
    (length files))

  (let loop ((files files)
             (completed 0))
    (match files
      (()
       (unless (zero? total)
         (report-load #f total completed))
       *unspecified*)
      ((file files ...)
       (let ((file (relative-file directory file)))
         (report-load file total completed)
         (format debug-port "~%loading '~a'...~%" file)

         (resolve-interface (file-name->module-name file))

         (loop files (+ 1 completed)))))))

(define-syntax-rule (with-augmented-search-path path item body ...)
  "Within the dynamic extent of BODY, augment PATH by adding ITEM to the
front."
  (let ((initial-value path))
    (dynamic-wind
      (lambda ()
        (set! path (cons item path)))
      (lambda ()
        body ...)
      (lambda ()
        (set! path initial-value)))))

(define (call/exit-on-exception file thunk)
  "Evaluate THUNK and exit right away if an exception is thrown.  Report FILE
as the file that was being compiled when the exception was thrown."
  (catch #t
    thunk
    (const #f)
    (lambda (key . args)
      (false-if-exception
       ;; Duplicate stderr to avoid thread-safety issues.
       (let* ((port  (duplicate-port (current-error-port) "w0"))
              (stack (make-stack #t))
              (depth (stack-length stack))
              (frame (and (> depth 1) (stack-ref stack 1))))
         (newline port)
         (format port "error: failed to compile '~a':~%~%" file)
         (false-if-exception (display-backtrace stack port))
         (print-exception port frame key args)))

      ;; Don't go any further.
      (primitive-exit 1))))

(define-syntax-rule (exit-on-exception file exp ...)
  "Evaluate EXP and exit if an exception is thrown.  Report FILE as the faulty
file when an exception is thrown."
  (call/exit-on-exception file (lambda () exp ...)))

(define* (compile-files source-directory build-directory files
                        #:key
                        (host %host-type)
                        (workers (current-processor-count))
                        (optimization-options optimization-options)
                        (warning-options `(#:warnings ,%warnings))
                        (report-load (const #f))
                        (report-compilation (const #f))
                        (debug-port (%make-void-port "w")))
  "Compile FILES, a list of source files taken from SOURCE-DIRECTORY, to
BUILD-DIRECTORY, using up to WORKERS parallel workers.  The resulting object
files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
  (define progress-lock (make-mutex))
  (define total (length files))
  (define progress 0)

  (define (build file)
    (with-mutex progress-lock
      (report-compilation file total progress)
      (set! progress (+ 1 progress)))

    ;; Exit as soon as something goes wrong.
    (exit-on-exception
     file
     (let ((relative (relative-file source-directory file)))
       (compile-file file
                     #:output-file (string-append build-directory "/"
                                                  (scm->go relative))
                     #:opts (append warning-options
                                    (optimization-options relative))))))

  (with-augmented-search-path %load-path source-directory
    (with-augmented-search-path %load-compiled-path build-directory
      (with-fluids ((*current-warning-prefix* ""))
        ;; Make sure the compiler's modules are loaded before 'with-target'
        ;; (since 'with-target' influences the .go loader), and before
        ;; starting to compile files in parallel.
        (compile #f)

        (with-target host
          (lambda ()
            ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first
            ;; load all of FILES.
            (load-files source-directory files
                        #:report-load report-load
                        #:debug-port debug-port)

            ;; XXX: Don't use too many workers to work around the insane
            ;; memory requirements of the compiler in Guile 2.2.2:
            ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>.
            (n-par-for-each (min workers 8) build files)

            (unless (zero? total)
              (report-compilation #f total total))))))))

(eval-when (eval load)
  (when (and (string=? "2" (major-version))
             (or (string=? "0" (minor-version))
                 (and (string=? (minor-version) "2")
                      (< (string->number (micro-version)) 4))))
    ;; Work around <https://bugs.gnu.org/31878> on Guile < 2.2.4.
    ;; Serialize 'try-module-autoload' calls.
    (set! (@ (guile) try-module-autoload)
      (let ((mutex (make-mutex 'recursive))
            (real  (@ (guile) try-module-autoload)))
        (lambda* (module #:optional version)
          (with-mutex mutex
            (real module version)))))))

;;; Local Variables:
;;; eval: (put 'with-augmented-search-path 'scheme-indent-function 2)
;;; eval: (put 'with-target 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz>
;;;
;;; 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 copy-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
            copy-build))

;; Commentary:
;;
;; System for building packages that don't require much compilation, mostly
;; only to copy files around.
;;
;; Code:

(define* (install #:key install-plan outputs #:allow-other-keys)
  "Copy files from the \"source\" build input to the \"out\" output according to INSTALL-PLAN.

An install plan is a list of plans in the form:

  (SOURCE TARGET [FILTERS])

In the above, FILTERS are optional.

- When SOURCE matches a file or directory without trailing slash, install it to
  TARGET.
  - If TARGET has a trailing slash, install SOURCE basename beneath TARGET.
  - Otherwise install SOURCE as TARGET.

- When SOURCE is a directory with a trailing slash, or when FILTERS are used,
  the trailing slash of TARGET is implied.
  - Without FILTERS, install the full SOURCE _content_ to TARGET.
    The paths relative to SOURCE are preserved within TARGET.
  - With FILTERS among `#:include`, `#:include-regexp`, `#:exclude`,
    `#:exclude-regexp`:
    - With `#:include`, install only the paths which suffix exactly matches
      one of the elements in the list.
    - With `#:include-regexp`, install subpaths matching the regexps in the list.
    - The `#:exclude*` FILTERS work similarly.  Without `#:include*` flags,
      install every subpath but the files matching the `#:exlude*` filters.
      If both `#:include*` and `#:exclude*` are specified, the exclusion is done
      on the inclusion list.

Examples:

- `(\"foo/bar\" \"share/my-app/\")`: Install bar to \"share/my-app/bar\".
- `(\"foo/bar\" \"share/my-app/baz\")`: Install bar to \"share/my-app/baz\".
- `(\"foo/\" \"share/my-app\")`: Install the content of foo inside \"share/my-app\",
  e.g. install \"foo/sub/file\" to \"share/my-app/sub/file\".
- `(\"foo/\" \"share/my-app\" #:include (\"sub/file\"))`: Install only \"foo/sub/file\" to
\"share/my-app/sub/file\".
- `(\"foo/sub\" \"share/my-app\" #:include (\"file\"))`: Install \"foo/sub/file\" to
\"share/my-app/file\"."
  (define (install-simple source target)
    "Install SOURCE to TARGET.
TARGET must point to a store location.
SOURCE may be a file or a directory.
If a directory, the directory itself is installed, not its content.
if TARGET ends with a '/', the source is installed underneath."
    (let ((target (if (string-suffix? "/" target)
                      (string-append target (basename source))
                      target)))
      (mkdir-p (dirname target))
      (copy-recursively source target)))

  (define (install-file file target)
    (let ((dest (string-append target
                               (if (string-suffix? "/" target)
                                   (string-append "/" file)
                                   file))))
      (format (current-output-port) "`~a' -> `~a'~%" file dest)
      (mkdir-p (dirname dest))
      (let ((stat (lstat file)))
        (case (stat:type stat)
          ((symlink)
           (let ((target (readlink file)))
             (symlink target dest)))
          (else
           (copy-file file dest))))))

  (define* (make-file-predicate suffixes matches-regexp #:optional (default-value #t))
    "Return a predicate that returns #t if its file argument matches the
SUFFIXES or the MATCHES-REGEXP.  If neither SUFFIXES nor MATCHES-REGEXP is
given, then the predicate always returns DEFAULT-VALUE."
    (if (or suffixes matches-regexp)
        (let* ((suffixes (or suffixes '()))
               (regexps (map make-regexp (or matches-regexp '())))
               (predicates (append
                            (map (lambda (str)
                                   (cut string-suffix? str <>))
                                 suffixes)
                            (map (lambda (regexp)
                                   (cut regexp-exec regexp <>))
                                 regexps))))
          (lambda (file)
            (any (cut <> file) predicates)))
        (const default-value)))

  (define* (install-file-list source target #:key include exclude include-regexp exclude-regexp)
    ;; We must use switch current directory to source so that `find-files'
    ;; returns file paths relative to source.
    (with-directory-excursion source
      (let* ((exclusion-pred (negate (make-file-predicate exclude exclude-regexp #f)))
             (inclusion-pred (make-file-predicate include include-regexp))
             (file-list
              (filter! exclusion-pred
                       (find-files "." (lambda (file _stat)
                                         (inclusion-pred file))))))
        (map (cut install-file <> (if (string-suffix? "/" target)
                                      target
                                      (string-append target "/")))
             file-list))))

  (define* (install source target #:key include exclude include-regexp exclude-regexp)
    (set! target (string-append (assoc-ref outputs "out") "/" target))
    (let ((filters? (or include exclude include-regexp exclude-regexp)))
      (when (and (not (file-is-directory? source))
                 filters?)
        (error "Cannot use filters when SOURCE is a file."))
      (let ((multi-files-in-source?
             (or (string-suffix? "/" source)
                 (and (file-is-directory? source)
                      filters?))))
        (if multi-files-in-source?
            (install-file-list source target
                               #:include include
                               #:exclude exclude
                               #:include-regexp include-regexp
                               #:exclude-regexp exclude-regexp)
            (install-simple source target)))))

  (for-each (lambda (plan) (apply install plan)) install-plan)
  #t)

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases gnu:%standard-phases
    (delete 'bootstrap)
    (delete 'configure)
    (delete 'build)
    (delete 'check)
    (replace 'install install)))

(define* (copy-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))

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

repo_name: maximed/guix

license: mit


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

(define-module (guix build cvs)
  #:use-module (guix build utils)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 ftw)
  #:export (cvs-fetch))

;;; Commentary:
;;;
;;; This is the build-side support code of (guix cvs-download).  It allows a
;;; CVS repository to be checked out at a specific revision or date.
;;;
;;; Code:

(define (find-cvs-directories)
  (define (enter? path st result)
    (not (string-suffix? "/CVS" path)))
  (define (leaf path st result) result)
  (define (down path st result) result)
  (define (up   path st result) result)
  (define (skip path st result)
    (if (and (string-suffix? "/CVS" path)
             (eqv? 'directory (stat:type st)))
        (cons path result)
        result))
  (define (error path st errno result)
    (format (current-error-port) "cvs-fetch: ~a: ~a~%"
            path (strerror errno)))
  (sort (file-system-fold enter? leaf down up skip error '() "." lstat)
        string<?))

(define* (cvs-fetch cvs-root-directory module revision directory
                    #:key (cvs-command "cvs"))
  "Fetch REVISION from MODULE of CVS-ROOT-DIRECTORY into DIRECTORY.  REVISION
must either be a date in ISO-8601 format (e.g. \"2012-12-21\") or a CVS tag.
Return #t on success, #f otherwise."
  ;; Use "-z0" because enabling compression leads to hangs during checkout on
  ;; certain repositories, such as
  ;; ":pserver:anonymous@cvs.savannah.gnu.org:/sources/gnustandards".
  (invoke cvs-command "-z0"
          "-d" cvs-root-directory
          "checkout"
          (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision)
              "-D" "-r")
          revision
          module)

  ;; Copy rather than rename in case MODULE and DIRECTORY are on
  ;; different devices.
  (copy-recursively module directory)

  (with-directory-excursion directory
    (for-each delete-file-recursively (find-cvs-directories)))
  #t)

;;; cvs.scm ends here


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

(define-module (guix build debug-link)
  #:use-module (guix elf)
  #:use-module ((guix build utils)
                #:select (find-files elf-file? make-file-writable))
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (system foreign)
  #:use-module (ice-9 match)
  #:export (debuglink-crc32
            elf-debuglink
            set-debuglink-crc

            graft-debug-links))

;;; Commentary:
;;;
;;; This module provides tools to deal with '.gnu_debuglink' sections in ELF
;;; files.  These sections are created by 'objcopy --add-gnu-debuglink' to
;;; create separate debug files (info "(gdb) Separate Debug Files").
;;;
;;; The main facility of this module is 'graft-debug-links', which allows us
;;; to update the CRC that appears in '.gnu_debuglink' sections when grafting,
;;; such that separate debug files remain usable after grafting.  Failing to
;;; do that, GDB would complain about CRC mismatch---see
;;; <https://bugs.gnu.org/19973>.
;;;
;;; Code:

(define %crc32-table
  ;; CRC table taken from "(gdb) Separate Debug Files".
  ;; TODO: Wouldn't it be nice to generate it "from source" with a macro?
  #(#x00000000 #x77073096 #xee0e612c #x990951ba #x076dc419
    #x706af48f #xe963a535 #x9e6495a3 #x0edb8832 #x79dcb8a4
    #xe0d5e91e #x97d2d988 #x09b64c2b #x7eb17cbd #xe7b82d07
    #x90bf1d91 #x1db71064 #x6ab020f2 #xf3b97148 #x84be41de
    #x1adad47d #x6ddde4eb #xf4d4b551 #x83d385c7 #x136c9856
    #x646ba8c0 #xfd62f97a #x8a65c9ec #x14015c4f #x63066cd9
    #xfa0f3d63 #x8d080df5 #x3b6e20c8 #x4c69105e #xd56041e4
    #xa2677172 #x3c03e4d1 #x4b04d447 #xd20d85fd #xa50ab56b
    #x35b5a8fa #x42b2986c #xdbbbc9d6 #xacbcf940 #x32d86ce3
    #x45df5c75 #xdcd60dcf #xabd13d59 #x26d930ac #x51de003a
    #xc8d75180 #xbfd06116 #x21b4f4b5 #x56b3c423 #xcfba9599
    #xb8bda50f #x2802b89e #x5f058808 #xc60cd9b2 #xb10be924
    #x2f6f7c87 #x58684c11 #xc1611dab #xb6662d3d #x76dc4190
    #x01db7106 #x98d220bc #xefd5102a #x71b18589 #x06b6b51f
    #x9fbfe4a5 #xe8b8d433 #x7807c9a2 #x0f00f934 #x9609a88e
    #xe10e9818 #x7f6a0dbb #x086d3d2d #x91646c97 #xe6635c01
    #x6b6b51f4 #x1c6c6162 #x856530d8 #xf262004e #x6c0695ed
    #x1b01a57b #x8208f4c1 #xf50fc457 #x65b0d9c6 #x12b7e950
    #x8bbeb8ea #xfcb9887c #x62dd1ddf #x15da2d49 #x8cd37cf3
    #xfbd44c65 #x4db26158 #x3ab551ce #xa3bc0074 #xd4bb30e2
    #x4adfa541 #x3dd895d7 #xa4d1c46d #xd3d6f4fb #x4369e96a
    #x346ed9fc #xad678846 #xda60b8d0 #x44042d73 #x33031de5
    #xaa0a4c5f #xdd0d7cc9 #x5005713c #x270241aa #xbe0b1010
    #xc90c2086 #x5768b525 #x206f85b3 #xb966d409 #xce61e49f
    #x5edef90e #x29d9c998 #xb0d09822 #xc7d7a8b4 #x59b33d17
    #x2eb40d81 #xb7bd5c3b #xc0ba6cad #xedb88320 #x9abfb3b6
    #x03b6e20c #x74b1d29a #xead54739 #x9dd277af #x04db2615
    #x73dc1683 #xe3630b12 #x94643b84 #x0d6d6a3e #x7a6a5aa8
    #xe40ecf0b #x9309ff9d #x0a00ae27 #x7d079eb1 #xf00f9344
    #x8708a3d2 #x1e01f268 #x6906c2fe #xf762575d #x806567cb
    #x196c3671 #x6e6b06e7 #xfed41b76 #x89d32be0 #x10da7a5a
    #x67dd4acc #xf9b9df6f #x8ebeeff9 #x17b7be43 #x60b08ed5
    #xd6d6a3e8 #xa1d1937e #x38d8c2c4 #x4fdff252 #xd1bb67f1
    #xa6bc5767 #x3fb506dd #x48b2364b #xd80d2bda #xaf0a1b4c
    #x36034af6 #x41047a60 #xdf60efc3 #xa867df55 #x316e8eef
    #x4669be79 #xcb61b38c #xbc66831a #x256fd2a0 #x5268e236
    #xcc0c7795 #xbb0b4703 #x220216b9 #x5505262f #xc5ba3bbe
    #xb2bd0b28 #x2bb45a92 #x5cb36a04 #xc2d7ffa7 #xb5d0cf31
    #x2cd99e8b #x5bdeae1d #x9b64c2b0 #xec63f226 #x756aa39c
    #x026d930a #x9c0906a9 #xeb0e363f #x72076785 #x05005713
    #x95bf4a82 #xe2b87a14 #x7bb12bae #x0cb61b38 #x92d28e9b
    #xe5d5be0d #x7cdcefb7 #x0bdbdf21 #x86d3d2d4 #xf1d4e242
    #x68ddb3f8 #x1fda836e #x81be16cd #xf6b9265b #x6fb077e1
    #x18b74777 #x88085ae6 #xff0f6a70 #x66063bca #x11010b5c
    #x8f659eff #xf862ae69 #x616bffd3 #x166ccf45 #xa00ae278
    #xd70dd2ee #x4e048354 #x3903b3c2 #xa7672661 #xd06016f7
    #x4969474d #x3e6e77db #xaed16a4a #xd9d65adc #x40df0b66
    #x37d83bf0 #xa9bcae53 #xdebb9ec5 #x47b2cf7f #x30b5ffe9
    #xbdbdf21c #xcabac28a #x53b39330 #x24b4a3a6 #xbad03605
    #xcdd70693 #x54de5729 #x23d967bf #xb3667a2e #xc4614ab8
    #x5d681b02 #x2a6f2b94 #xb40bbe37 #xc30c8ea1 #x5a05df1b
    #x2d02ef8d))

(define (debuglink-crc32 port)
  "Compute the 32-bit CRC used in in '.gnu_debuglink' over the data read from
PORT and return it."                      ;(info "(gdb) Separate Debug Files")
  (let loop ((crc #xffffffff))
    (let ((byte (get-u8 port)))
      (if (eof-object? byte)
          (logand (lognot crc) #xffffffff)
          (let* ((index (logand (logxor crc byte) #xff))
                 (lhs   (vector-ref %crc32-table index)))
            (loop (logxor lhs (ash crc -8))))))))

(define (section-contents elf section)     ;XXX: copied from linux-modules.scm
  "Return the contents of SECTION in ELF as a bytevector."
  (let* ((contents (make-bytevector (elf-section-size section))))
    (bytevector-copy! (elf-bytes elf) (elf-section-offset section)
                      contents 0
                      (elf-section-size section))
    contents))

(define null-terminated-bytevector->string
  (compose pointer->string bytevector->pointer))

(define (elf-debuglink elf)
  "Return two values: the '.gnu_debuglink' file name of ELF and its CRC.
Return #f for both if ELF lacks a '.gnu_debuglink' section."
  (let ((section (elf-section-by-name elf ".gnu_debuglink")))
    (if section
        (let ((size       (elf-section-size section))
              (bv         (section-contents elf section))
              (endianness (elf-byte-order elf)))
          (values (null-terminated-bytevector->string bv)
                  (bytevector-u32-ref bv (- size 4) endianness)))
        (values #f #f))))

(define (elf-debuglink-crc-offset elf)
  "Return the offset of the '.gnu_debuglink' 32-bit CRC, or #f if ELF lacks a
'.gnu_debuglink' section."
  (let ((section (elf-section-by-name elf ".gnu_debuglink")))
    (and section
         (+ (elf-section-offset section)
            (elf-section-size section)
            -4))))

(define (set-debuglink-crc file debug-file)
  "Compute the CRC of DEBUG-FILE and set it as the '.gnu_debuglink' CRC in
FILE."
  (let* ((elf    (parse-elf (call-with-input-file file get-bytevector-all)))
         (offset (elf-debuglink-crc-offset elf)))
    (and offset
         (let* ((crc (call-with-input-file debug-file debuglink-crc32))
                (bv  (make-bytevector 4)))
           (bytevector-u32-set! bv 0 crc (elf-byte-order elf))
           (let ((port (open file O_RDWR)))
             (set-port-position! port offset)
             (put-bytevector port bv)
             (close-port port))))))

;;;
;;; Updating debuglink CRC.
;;;

(define (find-elf-files outputs)
  "Return the list of ELF files found in OUTPUTS, a list of top-level store
directories."
  (define directories
    (append-map (lambda (output)
                  (list (string-append output "/bin")
                        (string-append output "/sbin")
                        (string-append output "/lib")
                        (string-append output "/libexec")))
                outputs))

  (append-map (lambda (directory)
                (filter elf-file?
                        (with-error-to-port (%make-void-port "w")
                          (lambda ()
                            (find-files directory)))))
              directories))

(define* (graft-debug-links old-outputs new-outputs mapping
                            #:key (log-port (current-error-port)))
  "Update the '.gnu_debuglink' CRCs found in ELF files of NEW-OUTPUTS,
provided NEW-OUTPUTS contains a \"debug\" output, such that those CRCs match
those of the corresponding '.debug' files found in the \"debug\" output.

This procedure is meant to be used as a \"grafting hook\" by (guix build
graft)."
  (match (assoc-ref new-outputs "debug")
    (#f #t)                                       ;nothing to do
    (debug-directory
     (let ((files (find-elf-files (filter-map (match-lambda
                                                (("debug" . _)
                                                 #f)
                                                ((name . directory)
                                                 directory))
                                              new-outputs))))
       (for-each (lambda (file)
                   (let ((debug (string-append debug-directory
                                               "/lib/debug" file ".debug")))
                     (when (file-exists? debug)
                       (format log-port
                               "updating '.gnu_debuglink' CRC in '~a'~%"
                               file)
                       (make-file-writable file)
                       (set-debuglink-crc file debug))))
                 files)))))


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

(define-module (guix build download-nar)
  #:use-module (guix build download)
  #:use-module (guix build utils)
  #:use-module ((guix serialization) #:hide (dump-port*))
  #:autoload   (zlib) (call-with-gzip-input-port)
  #:use-module (guix progress)
  #:use-module (web uri)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (download-nar))

;;; Commentary:
;;;
;;; Download a normalized archive or "nar", similar to what 'guix substitute'
;;; does.  The intent here is to use substitute servers as content-addressed
;;; mirrors of VCS checkouts.  This is mostly useful for users who have
;;; disabled substitutes.
;;;
;;; Code:

(define (urls-for-item item)
  "Return the fallback nar URL for ITEM--e.g.,
\"/gnu/store/cabbag3…-foo-1.2-checkout\"."
  ;; Here we hard-code nar URLs without checking narinfos.  That's probably OK
  ;; though.  Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to
  ;; avoid sending these requests to CDN providers without user consent.
  ;; TODO: Use HTTPS?  The downside is the extra dependency.
  (let ((bases '("http://berlin.guix.gnu.org"))
        (item  (basename item)))
    (append (map (cut string-append <> "/nar/gzip/" item) bases)
            (map (cut string-append <> "/nar/" item) bases))))

(define (restore-gzipped-nar port item size)
  "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
ITEM."
  ;; Since PORT is typically a non-file port (for instance because 'http-get'
  ;; returns a delimited port), create a child process so we're back to a file
  ;; port that can be passed to 'call-with-gzip-input-port'.
  (match (pipe)
    ((input . output)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #t)
          (lambda ()
            (close-port output)
            (close-port port)
            (catch #t
              (lambda ()
                (call-with-gzip-input-port input
                  (cut restore-file <> item)))
              (lambda (key . args)
                (print-exception (current-error-port)
                                 (stack-ref (make-stack #t) 1)
                                 key args)
                (primitive-exit 1))))
          (lambda ()
            (primitive-exit 0))))
       (child
        (close-port input)
        (dump-port* port output
                    #:reporter (progress-reporter/file item size
                                                       #:abbreviation
                                                       store-path-abbreviation))
        (close-port output)
        (newline)
        (match (waitpid child)
          ((_ . status)
           (unless (zero? status)
             (error "nar decompression failed" status)))))))))

(define (download-nar item)
  "Download and extract the normalized archive for ITEM.  Return #t on
success, #f otherwise."
  ;; Let progress reports go through.
  (setvbuf (current-error-port) 'none)
  (setvbuf (current-output-port) 'none)

  (let loop ((urls (urls-for-item item)))
    (match urls
      ((url rest ...)
       (format #t "Trying content-addressed mirror at ~a...~%"
               (uri-host (string->uri url)))
       (let-values (((port size)
                     (catch #t
                       (lambda ()
                         (http-fetch (string->uri url)))
                       (lambda args
                         (values #f #f)))))
         (if (not port)
             (loop rest)
             (begin
               (if size
                   (format #t "Downloading from ~a (~,2h MiB)...~%" url
                           (/ size (expt 2 20.)))
                   (format #t "Downloading from ~a...~%" url))
               (if (string-contains url "/gzip")
                   (restore-gzipped-nar port item size)
                   (begin
                     ;; FIXME: Add progress report.
                     (restore-file port item)
                     (close-port port)))
               #t))))
      (()
       #f))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 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/>.

(define-module (guix build download)
  #:use-module (web uri)
  #:use-module (web http)
  #:use-module ((web client) #:hide (open-socket-for-uri))
  #:use-module (web response)
  #:use-module (guix base64)
  #:use-module (guix ftp-client)
  #:use-module (guix build utils)
  #:use-module (guix progress)
  #:use-module (rnrs io ports)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:autoload   (ice-9 ftw) (scandir)
  #:autoload   (guix base16) (bytevector->base16-string)
  #:autoload   (guix swh) (swh-download-directory)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (open-socket-for-uri
            open-connection-for-uri
            http-fetch
            %x509-certificate-directory
            close-connection
            resolve-uri-reference
            maybe-expand-mirrors
            url-fetch
            byte-count->string
            uri-abbreviation
            nar-uri-abbreviation
            store-path-abbreviation))

;;; Commentary:
;;;
;;; Fetch data such as tarballs over HTTP or FTP (builder-side code).
;;;
;;; Code:

(define %http-receive-buffer-size
  ;; Size of the HTTP receive buffer.
  65536)

(define* (ellipsis #:optional (port (current-output-port)))
  "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
in PORT's encoding, and return either that or ASCII dots."
  (if (equal? (port-encoding port) "UTF-8")
      "…"
      "..."))

(define* (store-path-abbreviation store-path #:optional (prefix-length 6))
  "If STORE-PATH is the file name of a store entry, return an abbreviation of
STORE-PATH for display, showing PREFIX-LENGTH characters of the hash.
Otherwise return STORE-PATH."
  (if (string-prefix? (%store-directory) store-path)
      (let ((base (basename store-path)))
        (string-append (string-take base prefix-length)
                       (ellipsis)
                       (string-drop base 32)))
      store-path))

(define* (uri-abbreviation uri #:optional (max-length 42))
  "If URI's string representation is larger than MAX-LENGTH, return an
abbreviation of URI showing the scheme, host, and basename of the file."
  (define uri-as-string
    (uri->string uri))

  (define (elide-path)
    (let* ((path   (uri-path uri))
           (base   (basename path))
           (prefix (string-append (symbol->string (uri-scheme uri)) "://"

                                  ;; `file' URIs have no host part.
                                  (or (uri-host uri) "")

                                  (string-append "/" (ellipsis) "/"))))
      (if (> (+ (string-length prefix) (string-length base)) max-length)
          (string-append prefix (ellipsis)
                         (string-drop base (quotient (string-length base) 2)))
          (string-append prefix base))))

  (if (> (string-length uri-as-string) max-length)
      (let ((short (elide-path)))
        (if (< (string-length short) (string-length uri-as-string))
            short
            uri-as-string))
      uri-as-string))

(define (nar-uri-abbreviation uri)
  "Abbreviate URI, which is assumed to be the URI of a nar as served by Hydra
and 'guix publish', something like
\"http://example.org/nar/1ldrllwbna0aw5z8kpci4fsvbd2w8cw4-texlive-bin-2015\"."
  (let* ((uri  (if (string? uri) (string->uri uri) uri))
         (path (basename (uri-path uri))))
    (if (and (> (string-length path) 33)
             (char=? (string-ref path 32) #\-))
        (string-drop path 33)
        path)))

(define* (ftp-fetch uri file #:key timeout print-build-trace?)
  "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
out if the connection could not be established in less than TIMEOUT seconds."
  (let* ((conn (match (and=> (uri-userinfo uri)
                             (cut string-split <> #\:))
                 (((? string? user))
                  (ftp-open (uri-host uri) #:timeout timeout
                                           #:username user))
                 (((? string? user) (? string? pass))
                  (ftp-open (uri-host uri) #:timeout timeout
                                           #:username user
                                           #:password pass))
                 (_ (ftp-open (uri-host uri) #:timeout timeout))))
         (size (false-if-exception (ftp-size conn (uri-path uri))))
         (in   (ftp-retr conn (basename (uri-path uri))
                         (dirname (uri-path uri))
                         #:timeout timeout)))
    (call-with-output-file file
      (lambda (out)
        (dump-port* in out
                    #:buffer-size %http-receive-buffer-size
                    #:reporter
                    (if print-build-trace?
                        (progress-reporter/trace
                         file (uri->string uri) size)
                        (progress-reporter/file
                         (uri-abbreviation uri) size)))))

    (ftp-close conn)
    (unless print-build-trace?
      (newline))
    file))

;; Autoload GnuTLS so that this module can be used even when GnuTLS is
;; not available.  At compile time, this yields "possibly unbound
;; variable" warnings, but these are OK: we know that the variables will
;; be bound if we need them, because (guix download) adds GnuTLS as an
;; input in that case.

(define (load-gnutls)
  ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
  ;; See <http://bugs.gnu.org/12202>.
  (module-use! (resolve-module '(guix build download))
               (resolve-interface '(gnutls)))
  (set! load-gnutls (const #t)))

(define %x509-certificate-directory
  ;; The directory where X.509 authority PEM certificates are stored.
  (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
                      (getenv "SSL_CERT_DIR")     ;like OpenSSL
                      "/etc/ssl/certs")))

(define (set-certificate-credentials-x509-trust-file!* cred file format)
  "Like 'set-certificate-credentials-x509-trust-file!', but without the file
name decoding bug described at
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
  (let ((data (call-with-input-file file get-bytevector-all)))
    (set-certificate-credentials-x509-trust-data! cred data format)))

(define (make-credendials-with-ca-trust-files directory)
  "Return certificate credentials with X.509 authority certificates read from
DIRECTORY.  Those authority certificates are checked when
'peer-certificate-status' is later called."
  (let ((cred  (make-certificate-credentials))
        (files (match (scandir directory (cut string-suffix? ".pem" <>))
                 ((or #f ())
                  ;; Some distros provide nothing but bundles (*.crt) under
                  ;; /etc/ssl/certs, so look for them.
                  (or (scandir directory (cut string-suffix? ".crt" <>))
                      '()))
                 (pem pem))))
    (for-each (lambda (file)
                (let ((file (string-append directory "/" file)))
                  ;; Protect against dangling symlinks.
                  (when (file-exists? file)
                    (set-certificate-credentials-x509-trust-file!*
                     cred file
                     x509-certificate-format/pem))))
              files)
    cred))

(define (peer-certificate session)
  "Return the certificate of the remote peer in SESSION."
  (match (session-peer-certificate-chain session)
    ((first _ ...)
     (import-x509-certificate first x509-certificate-format/der))))

(define (assert-valid-server-certificate session server)
  "Return #t if the certificate of the remote peer for SESSION is a valid
certificate for SERVER, where SERVER is the expected host name of peer."
  (define cert
    (peer-certificate session))

  ;; First check whether the server's certificate matches SERVER.
  (unless (x509-certificate-matches-hostname? cert server)
    (throw 'tls-certificate-error 'host-mismatch cert server))

  ;; Second check its validity and reachability from the set of authority
  ;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'.
  (match (peer-certificate-status session)
    (()                                           ;certificate is valid
     #t)
    ((statuses ...)
     (throw 'tls-certificate-error 'invalid-certificate cert server
            statuses))))

(define (print-tls-certificate-error port key args default-printer)
  "Print the TLS certificate error represented by ARGS in an intelligible
way."
  (match args
    (('host-mismatch cert server)
     (format port
             "X.509 server certificate for '~a' does not match: ~a~%"
             server (x509-certificate-dn cert)))
    (('invalid-certificate cert server statuses)
     (format port
             "X.509 certificate of '~a' could not be verified:~%~{  ~a~%~}"
             server
             (map certificate-status->string statuses)))))

(set-exception-printer! 'tls-certificate-error
                        print-tls-certificate-error)

(define* (tls-wrap port server #:key (verify-certificate? #t))
  "Return PORT wrapped in a TLS connection to SERVER.  SERVER must be a DNS
host name without trailing dot."
  (define (log level str)
    (format (current-error-port)
            "gnutls: [~a|~a] ~a" (getpid) level str))

  (load-gnutls)
  (let ((session  (make-session connection-end/client))
        (ca-certs (%x509-certificate-directory)))

    ;; Some servers such as 'cloud.github.com' require the client to support
    ;; the 'SERVER NAME' extension.  However, 'set-session-server-name!' is
    ;; not available in older GnuTLS releases.  See
    ;; <http://bugs.gnu.org/18526> for details.
    (if (module-defined? (resolve-interface '(gnutls))
                         'set-session-server-name!)
        (set-session-server-name! session server-name-type/dns server)
        (format (current-error-port)
                "warning: TLS 'SERVER NAME' extension not supported~%"))

    (set-session-transport-fd! session (fileno port))
    (set-session-default-priority! session)

    ;; The "%COMPAT" bit allows us to work around firewall issues (info
    ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>.
    ;; Explicitly disable SSLv3, which is insecure:
    ;; <https://tools.ietf.org/html/rfc7568>.
    (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0")

    (set-session-credentials! session
                              (if (and verify-certificate? ca-certs)
                                  (make-credendials-with-ca-trust-files
                                   ca-certs)
                                  (make-certificate-credentials)))

    ;; Uncomment the following lines in case of debugging emergency.
    ;;(set-log-level! 10)
    ;;(set-log-procedure! log)

    (let loop ((retries 5))
      (catch 'gnutls-error
        (lambda ()
          (handshake session))
        (lambda (key err proc . rest)
          (cond ((eq? err error/warning-alert-received)
                 ;; Like Wget, do no stop upon non-fatal alerts such as
                 ;; 'alert-description/unrecognized-name'.
                 (format (current-error-port)
                         "warning: TLS warning alert received: ~a~%"
                         (alert-description->string (alert-get session)))
                 (handshake session))
                (else
                 (if (or (fatal-error? err) (zero? retries))
                     (apply throw key err proc rest)
                     (begin
                       ;; We got 'error/again' or similar; try again.
                       (format (current-error-port)
                               "warning: TLS non-fatal error: ~a~%"
                               (error->string err))
                       (loop (- retries 1)))))))))

    ;; Verify the server's certificate if needed.
    (when verify-certificate?
      (catch 'tls-certificate-error
        (lambda ()
          (assert-valid-server-certificate session server))
        (lambda args
          (close-port port)
          (apply throw args))))

    (let ((record (session-record-port session)))
      (define (read! bv start count)
        (define read
          (catch 'gnutls-error
            (lambda ()
              (get-bytevector-n! record bv start count))
            (lambda (key err proc . rest)
              ;; When responding to "Connection: close" requests, some
              ;; servers close the connection abruptly after sending the
              ;; response body, without doing a proper TLS connection
              ;; termination.  Treat it as EOF.
              (if (eq? err error/premature-termination)
                  the-eof-object
                  (apply throw key err proc rest)))))

        (if (eof-object? read)
            0
            read))
      (define (write! bv start count)
        (put-bytevector record bv start count)
        (force-output record)
        count)
      (define (get-position)
        (port-position record))
      (define (set-position! new-position)
        (set-port-position! record new-position))
      (define (close)
        (unless (port-closed? port)
          (close-port port))
        (unless (port-closed? record)
          (close-port record)))

      (define (unbuffered port)
        (setvbuf port 'none)
        port)

      (setvbuf record 'block)

      ;; Return a port that wraps RECORD to ensure that closing it also
      ;; closes PORT, the actual socket port, and its file descriptor.
      ;; Make sure it does not introduce extra buffering (custom ports
      ;; are buffered by default as of Guile 3.0.5).
      ;; XXX: This wrapper would be unnecessary if GnuTLS could
      ;; automatically close SESSION's file descriptor when RECORD is
      ;; closed, but that doesn't seem to be possible currently (as of
      ;; 3.6.9).
      (unbuffered
       (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
                                             get-position set-position!
                                             close)))))

(define (ensure-uri uri-or-string)                ;XXX: copied from (web http)
  (cond
   ((string? uri-or-string) (string->uri uri-or-string))
   ((uri? uri-or-string) uri-or-string)
   (else (error "Invalid URI" uri-or-string))))

(define* (open-socket-for-uri uri-or-string #:key timeout)
  "Return an open input/output port for a connection to URI.  When TIMEOUT is
not #f, it must be a (possibly inexact) number denoting the maximum duration
in seconds to wait for the connection to complete; passed TIMEOUT, an
ETIMEDOUT error is raised."
  ;; Includes a fix for <http://bugs.gnu.org/15368> which affects Guile's
  ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead
  ;; of 'connect', and uses AI_ADDRCONFIG.

  (define http-proxy (current-http-proxy))
  (define uri (ensure-uri (or http-proxy uri-or-string)))
  (define addresses
    (let ((port (uri-port uri)))
      (delete-duplicates
       (getaddrinfo (uri-host uri)
                    (cond (port => number->string)
                          (else (symbol->string (uri-scheme uri))))
                    (if (number? port)
                        (logior AI_ADDRCONFIG AI_NUMERICSERV)
                        AI_ADDRCONFIG))
       (lambda (ai1 ai2)
         (equal? (addrinfo:addr ai1) (addrinfo:addr ai2))))))

  (let loop ((addresses addresses))
    (let* ((ai (car addresses))
           (s  (with-fluids ((%default-port-encoding #f))
                 ;; Restrict ourselves to TCP.
                 (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP))))
      (catch 'system-error
        (lambda ()
          (connect* s (addrinfo:addr ai) timeout)

          ;; Buffer input and output on this port.
          (setvbuf s 'block)
          ;; If we're using a proxy, make a note of that.
          (when http-proxy (set-http-proxy-port?! s #t))
          s)
        (lambda args
          ;; Connection failed, so try one of the other addresses.
          (close s)
          (if (null? (cdr addresses))
              (apply throw args)
              (loop (cdr addresses))))))))

(define (setup-http-tunnel port uri)
  "Establish over PORT an HTTP tunnel to the destination server of URI."
  (define target
    (string-append (uri-host uri) ":"
                   (number->string
                    (or (uri-port uri)
                        (match (uri-scheme uri)
                          ('http 80)
                          ('https 443))))))
  (format port "CONNECT ~a HTTP/1.1\r\n" target)
  (format port "Host: ~a\r\n\r\n" target)
  (force-output port)
  (read-response port))

(define* (open-connection-for-uri uri
                                  #:key
                                  timeout
                                  (verify-certificate? #t))
  "Like 'open-socket-for-uri', but also handle HTTPS connections.  The
resulting port must be closed with 'close-connection'.  When
VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
  ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually
  ;; undefined.  See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047.

  (define https?
    (eq? 'https (uri-scheme uri)))

  (define https-proxy (let ((proxy (getenv "https_proxy")))
                        (and (not (equal? proxy ""))
                             proxy)))

  (let-syntax ((with-https-proxy
                (syntax-rules ()
                  ((_ exp)
                   ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
                   (let ((thunk (lambda () exp)))
                     (if (and https?
                              (module-variable
                               (resolve-interface '(web client))
                               'current-http-proxy))
                         (parameterize ((current-http-proxy https-proxy))
                           (thunk))
                         (thunk)))))))
    (with-https-proxy
     (let ((s (open-socket-for-uri uri #:timeout timeout)))
       ;; Buffer input and output on this port.
       (setvbuf s 'block %http-receive-buffer-size)

       (when (and https? https-proxy)
         (setup-http-tunnel s uri))

       (if https?
           (tls-wrap s (uri-host uri)
                     #:verify-certificate? verify-certificate?)
           s)))))

(define (close-connection port)                   ;deprecated
  (unless (port-closed? port)
    (close-port port)))

;; XXX: This is an awful hack to make sure the (set-port-encoding! p
;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
;; where iconv is not available.
(module-define! (resolve-module '(web response))
                'set-port-encoding!
                (lambda (p e) #f))

(define (resolve-uri-reference ref base)
  "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
Return the resulting target URI."

  (define (merge-paths base-path rel-path)
    (let* ((base-components (string-split base-path #\/))
           (base-directory-components (match base-components
                                        ((components ... last) components)
                                        (() '())))
           (base-directory (string-join base-directory-components "/")))
      (string-append base-directory "/" rel-path)))

  (define (remove-dot-segments path)
    (let loop ((in
                ;; Drop leading "." and ".." components from a relative path.
                ;; (absolute paths will start with a "" component)
                (drop-while (match-lambda
                              ((or "." "..") #t)
                              (_ #f))
                            (string-split path #\/)))
               (out '()))
      (match in
        (("." . rest)
         (loop rest out))
        ((".." . rest)
         (match out
           ((or () (""))
            (error "remove-dot-segments: too many '..' components" path))
           (_
            (loop rest (cdr out)))))
        ((component . rest)
         (loop rest (cons component out)))
        (()
         (string-join (reverse out) "/")))))

  (cond ((or (uri-scheme ref)
             (uri-host   ref))
         (build-uri (or (uri-scheme ref)
                        (uri-scheme base))
                    #:userinfo (uri-userinfo ref)
                    #:host     (uri-host     ref)
                    #:port     (uri-port     ref)
                    #:path     (remove-dot-segments (uri-path ref))
                    #:query    (uri-query    ref)
                    #:fragment (uri-fragment ref)))
        ((string-null? (uri-path ref))
         (build-uri (uri-scheme base)
                    #:userinfo (uri-userinfo base)
                    #:host     (uri-host     base)
                    #:port     (uri-port     base)
                    #:path     (remove-dot-segments (uri-path base))
                    #:query    (or (uri-query ref)
                                   (uri-query base))
                    #:fragment (uri-fragment ref)))
        (else
         (build-uri (uri-scheme base)
                    #:userinfo (uri-userinfo base)
                    #:host     (uri-host     base)
                    #:port     (uri-port     base)
                    #:path     (remove-dot-segments
                                (if (string-prefix? "/" (uri-path ref))
                                    (uri-path ref)
                                    (merge-paths (uri-path base)
                                                 (uri-path ref))))
                    #:query    (uri-query    ref)
                    #:fragment (uri-fragment ref)))))

(define* (http-fetch uri #:key timeout (verify-certificate? #t))
  "Return an input port containing the data at URI, and the expected number of
bytes available or #f.  When TIMEOUT is true, bail out if the connection could
not be established in less than TIMEOUT seconds.  When VERIFY-CERTIFICATE? is
true, verify HTTPS certificates; otherwise simply ignore them."

  (define headers
    `(;; Some web sites, such as http://dist.schmorp.de, would block you if
      ;; there's no 'User-Agent' header, presumably on the assumption that
      ;; you're a spammer.  So work around that.
      (User-Agent . "GNU Guile")

      ;; Some servers, such as https://alioth.debian.org, return "406 Not
      ;; Acceptable" when not explicitly told that everything is accepted.
      (Accept . "*/*")

      ;; Basic authentication, if needed.
      ,@(match (uri-userinfo uri)
          ((? string? str)
           `((Authorization . ,(string-append "Basic "
                                              (base64-encode
                                               (string->utf8 str))))))
          (_ '()))))

  (let*-values (((connection)
                 (open-connection-for-uri uri
                                          #:timeout timeout
                                          #:verify-certificate?
                                          verify-certificate?))
                ((resp port)
                 (http-get uri #:port connection #:decode-body? #f
                           #:streaming? #t
                           #:headers headers))
                ((code)
                 (response-code resp)))
    (case code
      ((200)                                      ; OK
       (values port (response-content-length resp)))
      ((301                                       ; moved permanently
        302                                       ; found (redirection)
        303                                       ; see other
        307                                       ; temporary redirection
        308)                                      ; permanent redirection
       (let ((uri (resolve-uri-reference (response-location resp) uri)))
         (format #t "following redirection to `~a'...~%"
                 (uri->string uri))
         (close connection)
         (http-fetch uri
                     #:timeout timeout
                     #:verify-certificate? verify-certificate?)))
      (else
       (error "download failed" (uri->string uri)
              code (response-reason-phrase resp))))))

(define-syntax-rule (false-if-exception* body ...)
  "Like `false-if-exception', but print the exception on the error port."
  (catch #t
    (lambda ()
      body ...)
    (lambda (key . args)
      #f)
    (lambda (key . args)
      (print-exception (current-error-port) #f key args))))

(define (uri-vicinity dir file)
  "Concatenate DIR, slash, and FILE, keeping only one slash in between.
This is required by some HTTP servers."
  (string-append (string-trim-right dir #\/) "/"
                 (string-trim file #\/)))

(define (maybe-expand-mirrors uri mirrors)
  "If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist.
Return a list of URIs."
  (case (uri-scheme uri)
    ((mirror)
     (let ((kind (string->symbol (uri-host uri)))
           (path (uri-path uri)))
       (match (assoc-ref mirrors kind)
         ((mirrors ..1)
          (map (compose string->uri (cut uri-vicinity <> path))
               mirrors))
         (_
          (error "unsupported URL mirror kind" kind uri)))))
    (else
     (list uri))))

(define* (disarchive-fetch/any uris file
                               #:key (timeout 10) (verify-certificate? #t))
  "Fetch a Disarchive specification from any of URIS, assemble it,
and write the output to FILE."
  (define (fetch-specification uris)
    (any (lambda (uri)
           (false-if-exception*
            (let-values (((port size) (http-fetch uri
                                                  #:verify-certificate?
                                                  verify-certificate?
                                                  #:timeout timeout)))
              (let ((specification (read port)))
                (close-port port)
                specification))))
         uris))

  (define (resolve addresses output)
    (any (match-lambda
           (('swhid swhid)
            (match (string-split swhid #\:)
              (("swh" "1" "dir" id)
               (format #t "Downloading ~a from Software Heritage...~%" file)
               (false-if-exception*
                (swh-download-directory id output)))
              (_ #f)))
           (_ #f))
         addresses))

  (format #t "Trying to use Disarchive to assemble ~a...~%" file)
  (match (and=> (resolve-module '(disarchive) #:ensure #f)
                (lambda (disarchive)
                  (cons (module-ref disarchive '%disarchive-log-port)
                        (module-ref disarchive 'disarchive-assemble))))
    (#f (format #t "could not load Disarchive~%")
        #f)
    ((%disarchive-log-port . disarchive-assemble)
     (match (fetch-specification uris)
       (#f (format #t "could not find its Disarchive specification~%")
           #f)
       (spec (parameterize ((%disarchive-log-port (current-output-port)))
               (false-if-exception*
                (disarchive-assemble spec file #:resolver resolve))))))))

(define* (url-fetch url file
                    #:key
                    (timeout 10) (verify-certificate? #t)
                    (mirrors '()) (content-addressed-mirrors '())
                    (disarchive-mirrors '())
                    (hashes '())
                    print-build-trace?)
  "Fetch FILE from URL; URL may be either a single string, or a list of
string denoting alternate URLs for FILE.  Return #f on failure, and FILE
on success.

When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve
'mirror://' URIs.

HASHES must be a list of algorithm/hash pairs, where each algorithm is a
symbol such as 'sha256 and each hash is a bytevector.
CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash
algorithm and a hash, return a URL where the specified data can be retrieved
or #f.

When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates;
otherwise simply ignore them."
  (define uri
    (append-map (cut maybe-expand-mirrors <> mirrors)
                (match url
                  ((_ ...) (map string->uri url))
                  (_       (list (string->uri url))))))

  (define (fetch uri file)
    (format #t "~%Starting download of ~a~%From ~a...~%"
            file (uri->string uri))
    (case (uri-scheme uri)
      ((http https)
       (false-if-exception*
        (let-values (((port size)
                      (http-fetch uri
                                  #:verify-certificate? verify-certificate?
                                  #:timeout timeout)))
          (call-with-output-file file
            (lambda (output)
              (dump-port* port output
                          #:buffer-size %http-receive-buffer-size
                          #:reporter (if print-build-trace?
                                         (progress-reporter/trace
                                          file (uri->string uri) size)
                                         (progress-reporter/file
                                          (uri-abbreviation uri) size)))
              (newline)))
          file)))
      ((ftp)
       (false-if-exception* (ftp-fetch uri file
                                       #:timeout timeout
                                       #:print-build-trace?
                                       print-build-trace?)))
      (else
       (format #t "skipping URI with unsupported scheme: ~s~%"
               uri)
       #f)))

  (define content-addressed-uris
    (append-map (lambda (make-url)
                  (filter-map (match-lambda
                                ((hash-algo . hash)
                                 (let ((file (strip-store-file-name file)))
                                   (string->uri (make-url file hash-algo hash)))))
                              hashes))
                content-addressed-mirrors))

  (define disarchive-uris
    (append-map (match-lambda
                  ((? string? mirror)
                   (map (match-lambda
                          ((hash-algo . hash)
                           (string->uri
                            (string-append mirror
                                           (symbol->string hash-algo) "/"
                                           (bytevector->base16-string hash)))))
                        hashes)))
                disarchive-mirrors))

  ;; Make this unbuffered so 'progress-report/file' works as expected.  'line
  ;; means '\n', not '\r', so it's not appropriate here.
  (setvbuf (current-output-port) 'none)

  (setvbuf (current-error-port) 'line)

  (let try ((uri (append uri content-addressed-uris)))
    (match uri
      ((uri tail ...)
       (or (fetch uri file)
           (try tail)))
      (()
       ;; If we are looking for a software archive, one last thing we
       ;; can try is to use Disarchive to assemble it.
       (or (disarchive-fetch/any disarchive-uris file
                                 #:verify-certificate? verify-certificate?
                                 #:timeout timeout)
           (begin
             (format (current-error-port) "failed to download ~s from ~s~%"
                     file url)
             ;; Remove FILE in case we made an incomplete download, for
             ;; example due to ENOSPC.
             (catch 'system-error
               (lambda ()
                 (delete-file file))
               (const #f))
             #f))))))

;;; download.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 dub-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%standard-phases
            dub-build))

;; Commentary:
;;
;; Builder-side code of the DUB (the build tool for D) build system.
;;
;; Code:

;; FIXME: Needs to be parsed from url not package name.
(define (package-name->d-package-name name)
  "Return the package name of NAME."
  (match (string-split name #\-)
    (("d" rest ...)
     (string-join rest "-"))
    (_ #f)))

(define* (configure #:key inputs #:allow-other-keys)
  "Prepare one new directory with all the required dependencies.
   It's necessary to do this (instead of just using /gnu/store as the
   directory) because we want to hide the libraries in subdirectories
   lib/dub/... instead of polluting the user's profile root."
  (let* ((dir (mkdtemp! "/tmp/dub.XXXXXX"))
         (vendor-dir (string-append dir "/vendor")))
    (setenv "HOME" dir)
    (mkdir vendor-dir)
    (for-each
      (match-lambda
        ((name . path)
         (let* ((d-package (package-name->d-package-name name))
                (d-basename (basename path)))
           (when (and d-package path)
             (match (string-split (basename path) #\-)
               ((_ ... version)
                (symlink (string-append path "/lib/dub/" d-basename)
                         (string-append vendor-dir "/" d-basename))))))))
      inputs)
    (invoke "dub" "add-path" vendor-dir)
    #t))

(define (grep string file-name)
  "Find the first occurrence of STRING in the file named FILE-NAME.
   Return the position of this occurrence, or #f if none was found."
  (string-contains (call-with-input-file file-name get-string-all)
                   string))

(define (grep* string file-name)
  "Find the first occurrence of STRING in the file named FILE-NAME.
   Return the position of this occurrence, or #f if none was found.
   If the file named FILE-NAME doesn't exist, return #f."
  (catch 'system-error
    (lambda ()
      (grep string file-name))
    (lambda args
      #f)))

(define* (build #:key (dub-build-flags '())
                #:allow-other-keys)
  "Build a given DUB package."
  (unless (or (grep* "sourceLibrary" "package.json")
              (grep* "sourceLibrary" "dub.sdl") ; note: format is different!
              (grep* "sourceLibrary" "dub.json"))
    (apply invoke `("dub" "build" ,@dub-build-flags))
    (substitute* ".dub/dub.json"
      (("\"lastUpgrade\": \"[^\"]*\"")
       "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\"")))
  #t)

(define* (check #:key tests? #:allow-other-keys)
  (when tests?
    (invoke "dub" "test")
    (substitute* ".dub/dub.json"
      (("\"lastUpgrade\": \"[^\"]*\"")
       "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\"")))
  #t)

(define* (install #:key inputs outputs #:allow-other-keys)
  "Install a given DUB package."
  (let* ((out (assoc-ref outputs "out"))
         (outbin (string-append out "/bin"))
         (outlib (string-append out "/lib/dub/" (basename out))))
    (mkdir-p outbin)
    ;; TODO remove "-test-application"
    (copy-recursively "bin" outbin)
    (mkdir-p outlib)
    (copy-recursively "." (string-append outlib))
    #t))

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

(define* (dub-build #:key inputs (phases %standard-phases)
                      #:allow-other-keys #:rest args)
  "Build the given DUB 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 © 2018 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2019 Gabriel Hondet <gabrielhondet@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 dune-build-system)
  #:use-module ((guix build ocaml-build-system) #:prefix ocaml:)
  #:use-module (guix build utils)
  #:use-module (ice-9 match)
  #:export (%standard-phases
            dune-build))

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

(define* (build #:key (build-flags '()) (jbuild? #f)
                (use-make? #f) (package #f) #:allow-other-keys)
  "Build the given package."
  (let ((program (if jbuild? "jbuilder" "dune")))
    (apply invoke program "build" "@install"
           (append (if package (list "-p" package) '()) build-flags)))
  #t)

(define* (check #:key (test-flags '()) (test-target "test") tests?
                  (jbuild? #f) (package #f) #:allow-other-keys)
  "Test the given package."
  (when tests?
    (let ((program (if jbuild? "jbuilder" "dune")))
      (apply invoke program "runtest" test-target
             (append (if package (list "-p" package) '()) test-flags))))
  #t)

(define* (install #:key outputs (install-target "install") (jbuild? #f)
                  (package #f) #:allow-other-keys)
  "Install the given package."
  (let ((out (assoc-ref outputs "out"))
        (program (if jbuild? "jbuilder" "dune")))
    (apply invoke program install-target "--prefix" out "--libdir"
           (string-append out "/lib/ocaml/site-lib")
           (if package (list package) '())))
  #t)

(define %standard-phases
  ;; Everything is as with the GNU Build System except for the `configure'
  ;; , `build', `check' and `install' phases.
  (modify-phases ocaml:%standard-phases
    (delete 'configure)
    (replace 'build build)
    (replace 'check check)
    (replace 'install install)))

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

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


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

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

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

;;; The location in which Emacs looks for packages.  Emacs Lisp code that is
;;; installed there directly will be found when that directory is added to
;;; EMACSLOADPATH.  To avoid clashes between packages (particularly considering
;;; auxiliary files), we install them one directory level below, however.
;;; This indirection is handled by ‘expand-load-path’ during build and a
;;; profile hook otherwise.
(define %install-dir "/share/emacs/site-lisp")

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

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

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

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

(define* (expand-load-path #:key (prepend-source? #t) #:allow-other-keys)
  "Expand EMACSLOADPATH, so that inputs, whose code resides in subdirectories,
are properly found.
If @var{prepend-source?} is @code{#t} (the default), also add the current
directory to EMACSLOADPATH in front of any other directories."
  (let* ((source-directory (getcwd))
         (emacs-load-path (string-split (getenv "EMACSLOADPATH") #\:))
         (emacs-load-path*
          (map
           (lambda (dir)
             (match (scandir dir (negate (cute member <> '("." ".."))))
               ((sub) (string-append dir "/" sub))
               (_ dir)))
           emacs-load-path))
         (emacs-load-path-value (string-append
                                 (string-join
                                  (if prepend-source?
                                      (cons source-directory emacs-load-path*)
                                      emacs-load-path*)
                                  ":")
                                 ":")))
    (setenv "EMACSLOADPATH" emacs-load-path-value)
    (when prepend-source?
      (format #t "source directory ~s prepended to the `EMACSLOADPATH' \
environment variable\n" source-directory))
    (let ((diff (lset-difference string=? emacs-load-path* emacs-load-path)))
      (unless (null? diff)
        (format #t "expanded load paths for ~{~a~^, ~}\n"
                (map basename diff))))))

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

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

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

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

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

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

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

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

  (define source (getcwd))

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

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

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

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

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

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

(define* (enable-autoloads-compilation #:key outputs #:allow-other-keys)
  "Remove the NO-BYTE-COMPILATION local variable embedded in the generated
autoload files."
  (let* ((out (assoc-ref outputs "out"))
         (autoloads (find-files out "-autoloads.el$")))
    (substitute* autoloads
      ((";; no-byte-compile.*") ""))
    #t))

(define* (validate-compiled-autoloads #:key outputs #:allow-other-keys)
  "Verify whether the byte compiled autoloads load fine."
  (let* ((out (assoc-ref outputs "out"))
         (autoloads (find-files out "-autoloads.elc$")))
    (emacs-batch-eval (format #f "(mapc #'load '~s)" autoloads))))

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

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

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

(define (elpa-directory store-dir)
  "Given the store directory STORE-DIR return the absolute install directory
for libraries following the ELPA convention."
  (string-append store-dir %install-dir "/"
                 (store-directory->elpa-name-version store-dir)))

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

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

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


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

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

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

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

(define (expr->string expr)
  "Converts EXPR, an expression, into a string."
  (if (string? expr)
      expr
      (format #f "~s" expr)))

(define* (emacs-batch-eval expr #:key dynamic?)
  "Run Emacs in batch mode, and execute the Elisp code EXPR.  If DYNAMIC? is
true, evaluate using dynamic scoping."
  (invoke (%emacs) "--quick" "--batch"
          (format #f "--eval=(eval '~a ~:[t~;nil~])"
                  (expr->string expr) dynamic?)))

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

(define (emacs-batch-disable-compilation file)
  (emacs-batch-edit-file file
    '(progn
      (add-file-local-variable 'no-byte-compile t)
      (basic-save-buffer))))

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

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

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

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

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

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

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

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

;;; emacs-utils.scm ends here


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

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

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

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

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

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

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

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

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


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

(define-module (guix build git)
  #:use-module (guix build utils)
  #:use-module (srfi srfi-34)
  #:use-module (ice-9 format)
  #:export (git-fetch))

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

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

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

  (mkdir-p directory)

  (guard (c ((invoke-error? c)
             (format (current-error-port)
                     "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%"
                     (invoke-error-program c)
                     (invoke-error-arguments c)
                     (or (invoke-error-exit-status c) ;XXX: not quite accurate
                         (invoke-error-stop-signal c)
                         (invoke-error-term-signal c)))
             (delete-file-recursively directory)
             #f))
    (with-directory-excursion directory
      (invoke git-command "init")
      (invoke git-command "remote" "add" "origin" url)
      (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit))
          (invoke git-command "checkout" "FETCH_HEAD")
          (begin
            (setvbuf (current-output-port) 'line)
            (format #t "Failed to do a shallow fetch; retrying a full fetch...~%")
            (invoke git-command "fetch" "origin")
            (invoke git-command "checkout" commit)))
      (when recursive?
        ;; Now is the time to fetch sub-modules.
        (invoke git-command "submodule" "update" "--init" "--recursive")

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

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

;;; git.scm ends here