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

(define-module (guix upstream)
  #:use-module (guix records)
  #:use-module (guix utils)
  #:use-module (guix discovery)
  #:use-module ((guix download)
                #:select (download-to-store url-fetch))
  #:use-module (guix gnupg)
  #:use-module (guix packages)
  #:use-module (guix diagnostics)
  #:use-module (guix ui)
  #:use-module (guix base32)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
  #:autoload   (gcrypt hash) (port-sha256)
  #:use-module (guix monads)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (upstream-source
            upstream-source?
            upstream-source-package
            upstream-source-version
            upstream-source-urls
            upstream-source-signature-urls
            upstream-source-archive-types
            upstream-source-input-changes

            url-predicate
            url-prefix-predicate
            coalesce-sources

            upstream-updater
            upstream-updater?
            upstream-updater-name
            upstream-updater-description
            upstream-updater-predicate
            upstream-updater-latest

            upstream-input-change?
            upstream-input-change-name
            upstream-input-change-type
            upstream-input-change-action
            changed-inputs

            %updaters
            lookup-updater

            download-tarball
            package-latest-release
            package-latest-release*
            package-update
            update-package-source))

;;; Commentary:
;;;
;;; This module provides tools to represent and manipulate a upstream source
;;; code, and to auto-update package recipes.
;;;
;;; Code:

;; Representation of upstream's source.  There can be several URLs--e.g.,
;; tar.gz, tar.gz, etc.  There can be correspond signature URLs, one per
;; source URL.
(define-record-type* <upstream-source>
  upstream-source make-upstream-source
  upstream-source?
  (package        upstream-source-package)        ;string
  (version        upstream-source-version)        ;string
  (urls           upstream-source-urls)           ;list of strings
  (signature-urls upstream-source-signature-urls  ;#f | list of strings
                  (default #f))
  (input-changes  upstream-source-input-changes
                  (default '()) (thunked)))

;; Representation of an upstream input change.
(define-record-type* <upstream-input-change>
  upstream-input-change make-upstream-input-change
  upstream-input-change?
  (name    upstream-input-change-name)    ;string
  (type    upstream-input-change-type)    ;symbol: regular | native | propagated
  (action  upstream-input-change-action)) ;symbol: add | remove

(define (changed-inputs package package-sexp)
  "Return a list of input changes for PACKAGE based on the newly imported
S-expression PACKAGE-SEXP."
  (match package-sexp
    ((and expr ('package fields ...))
     (let* ((input->name (match-lambda ((name pkg . out) name)))
            (new-regular
             (match expr
               ((path *** ('inputs
                           ('quasiquote ((label ('unquote sym)) ...)))) label)
               (_ '())))
            (new-native
             (match expr
               ((path *** ('native-inputs
                           ('quasiquote ((label ('unquote sym)) ...)))) label)
               (_ '())))
            (new-propagated
             (match expr
               ((path *** ('propagated-inputs
                           ('quasiquote ((label ('unquote sym)) ...)))) label)
               (_ '())))
            (current-regular
             (map input->name (package-inputs package)))
            (current-native
             (map input->name (package-native-inputs package)))
            (current-propagated
             (map input->name (package-propagated-inputs package))))
       (append-map
        (match-lambda
          ((action type names)
           (map (lambda (name)
                  (upstream-input-change
                   (name name)
                   (type type)
                   (action action)))
                names)))
        `((add regular
           ,(lset-difference equal?
                             new-regular current-regular))
          (remove regular
           ,(lset-difference equal?
                             current-regular new-regular))
          (add native
           ,(lset-difference equal?
                             new-native current-native))
          (remove native
           ,(lset-difference equal?
                             current-native new-native))
          (add propagated
           ,(lset-difference equal?
                             new-propagated current-propagated))
          (remove propagated
           ,(lset-difference equal?
                             current-propagated new-propagated))))))
    (_ '())))

(define* (url-predicate matching-url?)
  "Return a predicate that returns true when passed a package whose source is
an <origin> with the URL-FETCH method, and one of its URLs passes
MATCHING-URL?."
  (lambda (package)
    (match (package-source package)
      ((? origin? origin)
       (and (eq? (origin-method origin) url-fetch)
            (match (origin-uri origin)
              ((? string? url)
               (matching-url? url))
              (((? string? urls) ...)
               (any matching-url? urls))
              (_
               #f))))
      (_ #f))))

(define (url-prefix-predicate prefix)
  "Return a predicate that returns true when passed a package where one of its
source URLs starts with PREFIX."
  (url-predicate (cut string-prefix? prefix <>)))

(define (upstream-source-archive-types release)
  "Return the available types of archives for RELEASE---a list of strings such
as \"gz\" or \"xz\"."
  (map file-extension (upstream-source-urls release)))

(define (coalesce-sources sources)
  "Coalesce the elements of SOURCES, a list of <upstream-source>, that
correspond to the same version."
  (define (same-version? r1 r2)
    (string=? (upstream-source-version r1) (upstream-source-version r2)))

  (define (release>? r1 r2)
    (version>? (upstream-source-version r1) (upstream-source-version r2)))

  (fold (lambda (release result)
          (match result
            ((head . tail)
             (if (same-version? release head)
                 (cons (upstream-source
                        (inherit release)
                        (urls (append (upstream-source-urls release)
                                      (upstream-source-urls head)))
                        (signature-urls
                         (let ((one (upstream-source-signature-urls release))
                               (two (upstream-source-signature-urls head)))
                           (and one two (append one two)))))
                       tail)
                 (cons release result)))
            (()
             (list release))))
        '()
        (sort sources release>?)))

;;;
;;; Auto-update.
;;;

(define-record-type* <upstream-updater>
  upstream-updater make-upstream-updater
  upstream-updater?
  (name        upstream-updater-name)
  (description upstream-updater-description)
  (pred        upstream-updater-predicate)
  (latest      upstream-updater-latest))

(define (importer-modules)
  "Return the list of importer modules."
  (cons (resolve-interface '(guix gnu-maintenance))
        (all-modules (map (lambda (entry)
                            `(,entry . "guix/import"))
                          %load-path)
                     #:warn warn-about-load-error)))

(define %updaters
  ;; The list of publically-known updaters.
  (delay (fold-module-public-variables (lambda (obj result)
                                         (if (upstream-updater? obj)
                                             (cons obj result)
                                             result))
                                       '()
                                       (importer-modules))))

;; Tests need to mock this variable so mark it as "non-declarative".
(set! %updaters %updaters)

(define* (lookup-updater package
                         #:optional (updaters (force %updaters)))
  "Return an updater among UPDATERS that matches PACKAGE, or #f if none of
them matches."
  (find (match-lambda
          (($ <upstream-updater> name description pred latest)
           (pred package)))
        updaters))

(define* (package-latest-release package
                                 #:optional
                                 (updaters (force %updaters)))
  "Return an upstream source to update PACKAGE, a <package> object, or #f if
none of UPDATERS matches PACKAGE.  When several updaters match PACKAGE, try
them until one of them returns an upstream source.  It is the caller's
responsibility to ensure that the returned source is newer than the current
one."
  (any (match-lambda
         (($ <upstream-updater> name description pred latest)
          (and (pred package)
               (latest package))))
       updaters))

(define* (package-latest-release* package
                                  #:optional
                                  (updaters (force %updaters)))
  "Like 'package-latest-release', but ensure that the return source is newer
than that of PACKAGE."
  (match (package-latest-release package updaters)
    ((and source ($ <upstream-source> name version))
     (and (version>? version (package-version package))
          source))
    (_
     #f)))

(define (uncompressed-tarball name tarball)
  "Return a derivation that decompresses TARBALL."
  (define (ref package)
    (module-ref (resolve-interface '(gnu packages compression))
                package))

  (define compressor
    (cond ((or (string-suffix? ".gz" tarball)
               (string-suffix? ".tgz" tarball))
           (file-append (ref 'gzip) "/bin/gzip"))
          ((string-suffix? ".bz2" tarball)
           (file-append (ref 'bzip2) "/bin/bzip2"))
          ((string-suffix? ".xz" tarball)
           (file-append (ref 'xz) "/bin/xz"))
          ((string-suffix? ".lz" tarball)
           (file-append (ref 'lzip) "/bin/lzip"))
          (else
           (error "unknown archive type" tarball))))

  (gexp->derivation (file-sans-extension name)
                    #~(begin
                        (copy-file #+tarball #+name)
                        (and (zero? (system* #+compressor "-d" #+name))
                             (copy-file #+(file-sans-extension name)
                                        #$output)))))

(define* (download-tarball store url signature-url
                           #:key (key-download 'interactive))
  "Download the tarball at URL to the store; check its OpenPGP signature at
SIGNATURE-URL, unless SIGNATURE-URL is false.  On success, return the tarball
file name; return #f on failure (network failure or authentication failure).
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'interactive' (default), 'always', and 'never'."
  (let ((tarball (download-to-store store url)))
    (if (not signature-url)
        tarball
        (let* ((sig  (download-to-store store signature-url))

               ;; Sometimes we get a signature over the uncompressed tarball.
               ;; In that case, decompress the tarball in the store so that we
               ;; can check the signature.
               (data (if (string-prefix? (basename url)
                                         (basename signature-url))
                         tarball
                         (run-with-store store
                           (mlet %store-monad ((drv (uncompressed-tarball
                                                     (basename url) tarball)))
                             (mbegin %store-monad
                               (built-derivations (list drv))
                               (return (derivation->output-path drv))))))))
          (let-values (((status data)
                        (if sig
                            (gnupg-verify* sig data
                                           #:key-download key-download)
                            (values 'missing-signature data))))
            (match status
              ('valid-signature
               tarball)
              ('missing-signature
               (warning (G_ "failed to download detached signature from ~a~%")
                        signature-url)
               #f)
              ('invalid-signature
               (warning (G_ "signature verification failed for '~a' (key: ~a)~%")
                        url data)
               #f)
              ('missing-key
               (warning (G_ "missing public key ~a for '~a'~%")
                        data url)
               #f)))))))

(define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
                                                system target)
  "Download SOURCE from its first URL and lower it as a fixed-output
derivation that would fetch it."
  (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
                       (signature
                        -> (and=> (upstream-source-signature-urls source)
                                  first))
                       (tarball ((store-lift download-tarball) url signature)))
    (unless tarball
      (raise (formatted-message (G_ "failed to fetch source from '~a'")
                                url)))

    ;; Instead of returning TARBALL, return a fixed-output derivation that
    ;; would be able to re-download it.  In practice, since TARBALL is already
    ;; in the store, no extra download will happen, but having the derivation
    ;; in store improves provenance tracking.
    (let ((hash (call-with-input-file tarball port-sha256)))
      (url-fetch url 'sha256 hash (store-path-package-name tarball)
                 #:system system))))

(define (find2 pred lst1 lst2)
  "Like 'find', but operate on items from both LST1 and LST2.  Return two
values: the item from LST1 and the item from LST2 that match PRED."
  (let loop ((lst1 lst1) (lst2 lst2))
    (match lst1
      ((head1 . tail1)
       (match lst2
         ((head2 . tail2)
          (if (pred head1 head2)
              (values head1 head2)
              (loop tail1 tail2)))))
      (()
       (values #f #f)))))

(define* (package-update/url-fetch store package source
                                   #:key key-download)
  "Return the version, tarball, and SOURCE, to update PACKAGE to
SOURCE, an <upstream-source>."
  (match source
    (($ <upstream-source> _ version urls signature-urls)
     (let*-values (((archive-type)
                    (match (and=> (package-source package) origin-uri)
                      ((? string? uri)
                       (let ((type (or (file-extension (basename uri)) "")))
                         ;; Sometimes we have URLs such as
                         ;; "https://github.com/…/tarball/v0.1", in which case
                         ;; we must not consider "1" as the extension.
                         (and (or (string-contains type "z")
                                  (string=? type "tar"))
                              type)))
                      (_
                       "gz")))
                   ((url signature-url)
                    ;; Try to find a URL that matches ARCHIVE-TYPE.
                    (find2 (lambda (url sig-url)
                             ;; Some URIs lack a file extension, like
                             ;; 'https://crates.io/???/0.1/download'.  In that
                             ;; case, pick the first URL.
                             (or (not archive-type)
                                 (string-suffix? archive-type url)))
                           urls
                           (or signature-urls (circular-list #f)))))
       ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
       ;; pick up the first element of URLS.
       (let ((tarball (download-tarball store
                                        (or url (first urls))
                                        (and (pair? signature-urls)
                                             (or signature-url
                                                 (first signature-urls)))
                                        #:key-download key-download)))
         (values version tarball source))))))

(define %method-updates
  ;; Mapping of origin methods to source update procedures.
  `((,url-fetch . ,package-update/url-fetch)))

(define* (package-update store package
                         #:optional (updaters (force %updaters))
                         #:key (key-download 'interactive))
  "Return the new version, the file name of the new version tarball, and input
changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
values: 'always', 'never', and 'interactive' (default)."
  (match (package-latest-release* package updaters)
    ((? upstream-source? source)
     (let ((method (match (package-source package)
                     ((? origin? origin)
                      (origin-method origin))
                     (_
                      #f))))
       (match (assq method %method-updates)
         (#f
          (raise (make-compound-condition
                  (formatted-message (G_ "cannot download for \
this method: ~s")
                                     method)
                  (condition
                   (&error-location
                    (location (package-location package)))))))
         ((_ . update)
          (update store package source
                  #:key-download key-download)))))
    (#f
     (values #f #f #f))))

(define* (update-package-source package source hash)
  "Modify the source file that defines PACKAGE to refer to SOURCE, an
<upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
new version string if an update was made, and #f otherwise."
  (define (update-expression expr replacements)
    ;; Apply REPLACEMENTS to package expression EXPR, a string.  REPLACEMENTS
    ;; must be a list of replacement pairs, either bytevectors or strings.
    (fold (lambda (replacement str)
            (match replacement
              (((? bytevector? old-bv) . (? bytevector? new-bv))
               (string-replace-substring
                str
                (bytevector->nix-base32-string old-bv)
                (bytevector->nix-base32-string new-bv)))
              ((old . new)
               (string-replace-substring str old new))))
          expr
          replacements))

  (let ((name        (package-name package))
        (version     (upstream-source-version source))
        (version-loc (package-field-location package 'version)))
    (if version-loc
        (let* ((loc         (package-location package))
               (old-version (package-version package))
               (old-hash    (content-hash-value
                             (origin-hash (package-source package))))
               (old-url     (match (origin-uri (package-source package))
                              ((? string? url) url)
                              (_ #f)))
               (new-url     (match (upstream-source-urls source)
                              ((first _ ...) first)))
               (file        (and=> (location-file loc)
                                   (cut search-path %load-path <>))))
          (if file
              ;; Be sure to use absolute filename.  Replace the URL directory
              ;; when OLD-URL is available; this is useful notably for
              ;; mirror://cpan/ URLs where the directory may change as a
              ;; function of the person who uploads the package.  Note that
              ;; package definitions usually concatenate fragments of the URL,
              ;; which is why we only attempt to replace a subset of the URL.
              (let ((properties (assq-set! (location->source-properties loc)
                                           'filename file))
                    (replacements `((,old-version . ,version)
                                    (,old-hash . ,hash)
                                    ,@(if (and old-url new-url)
                                          `((,(dirname old-url) .
                                             ,(dirname new-url)))
                                          '()))))
                (and (edit-expression properties
                                      (cut update-expression <> replacements))
                     version))
              (begin
                (warning (G_ "~a: could not locate source file")
                         (location-file loc))
                #f)))
        (warning (package-location package)
                 (G_ "~a: no `version' field in source; skipping~%")
                 name))))

;;; upstream.scm ends here

repo_name: maximed/guix

license: mit


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 © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2020 Marius Bakke <marius@gnu.org>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2021 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 utils)
  #:use-module (guix config)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-39)
  #:use-module (ice-9 ftw)
  #:use-module (rnrs io ports)                    ;need 'port-position' etc.
  #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
  #:use-module (guix memoization)
  #:use-module ((guix build utils) #:select (dump-port mkdir-p delete-file-recursively))
  #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
  #:use-module ((guix combinators) #:select (fold2))
  #:use-module (guix diagnostics)           ;<location>, &error-location, etc.
  #:use-module (ice-9 format)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module ((ice-9 iconv) #:prefix iconv:)
  #:autoload   (zlib) (make-zlib-input-port make-zlib-output-port)
  #:use-module (system foreign)
  #:re-export (<location>                         ;for backwards compatibility
               location
               location?
               location-file
               location-line
               location-column
               source-properties->location
               location->source-properties

               &error-location
               error-location?
               error-location

               &fix-hint
               fix-hint?
               condition-fix-hint)
  #:export (strip-keyword-arguments
            default-keyword-arguments
            substitute-keyword-arguments
            ensure-keyword-arguments

            current-source-directory

            nix-system->gnu-triplet
            gnu-triplet->nix-system
            %current-system
            %current-target-system
            package-name->name+version
            target-mingw?
            target-arm32?
            target-aarch64?
            target-arm?
            target-powerpc?
            target-64bit?
            cc-for-target
            cxx-for-target
            pkg-config-for-target

            version-compare
            version>?
            version>=?
            version-prefix
            version-major+minor+point
            version-major+minor
            version-major
            version-unique-prefix
            guile-version>?
            version-prefix?
            string-replace-substring
            file-extension
            file-sans-extension
            tarball-sans-extension
            compressed-file?
            switch-symlinks
            call-with-temporary-output-file
            call-with-temporary-directory
            with-atomic-file-output

            with-environment-variables
            arguments-from-environment-variable

            config-directory
            cache-directory

            readlink*
            edit-expression

            filtered-port
            decompressed-port
            call-with-decompressed-port
            compressed-output-port
            call-with-compressed-output-port
            canonical-newline-port

            string-distance
            string-closest

            pretty-print-table))

;;;
;;; Environment variables.
;;;

(define (call-with-environment-variables variables thunk)
  "Call THUNK with the environment VARIABLES set."
  (let ((environment (environ)))
    (dynamic-wind
      (lambda ()
        (for-each (match-lambda
                    ((variable value)
                     (setenv variable value)))
                  variables))
      thunk
      (lambda ()
        (environ environment)))))

(define-syntax-rule (with-environment-variables variables exp ...)
  "Evaluate EXP with the given environment VARIABLES set."
  (call-with-environment-variables variables
                                   (lambda () exp ...)))

(define (arguments-from-environment-variable variable)
  "Retrieve value of environment variable denoted by string VARIABLE in the
form of a list of strings (`char-set:graphic' tokens) suitable for consumption
by `args-fold', if VARIABLE is defined, otherwise return an empty list."
  (let ((env (getenv variable)))
    (if env
        (string-tokenize env char-set:graphic)
        '())))

;;;
;;; Filtering & pipes.
;;;

(define (filtered-port command input)
  "Return an input port where data drained from INPUT is filtered through
COMMAND (a list).  In addition, return a list of PIDs that the caller must
wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
buffered data is lost."
  (let loop ((input input)
             (pids  '()))
    (if (file-port? input)
        (match (pipe)
          ((in . out)
           (match (primitive-fork)
             (0
              (dynamic-wind
                (const #f)
                (lambda ()
                  (close-port in)
                  (close-port (current-input-port))
                  (dup2 (fileno input) 0)
                  (close-port (current-output-port))
                  (dup2 (fileno out) 1)
                  (catch 'system-error
                    (lambda ()
                      (apply execl (car command) command))
                    (lambda args
                      (format (current-error-port)
                              "filtered-port: failed to execute '~{~a ~}': ~a~%"
                              command (strerror (system-error-errno args))))))
                (lambda ()
                  (primitive-_exit 1))))
             (child
              (close-port out)
              (values in (cons child pids))))))

        ;; INPUT is not a file port, so fork just for the sake of tunneling it
        ;; through a file port.
        (match (pipe)
          ((in . out)
           (match (primitive-fork)
             (0
              (dynamic-wind
                (const #t)
                (lambda ()
                  (close-port in)
                  (dump-port input out))
                (lambda ()
                  (close-port input)
                  (false-if-exception (close out))
                  (primitive-_exit 0))))
             (child
              (close-port input)
              (close-port out)
              (loop in (cons child pids)))))))))

(define (lzip-port proc port . args)
  "Return the lzip port produced by calling PROC (a symbol) on PORT and ARGS.
Raise an error if lzlib support is missing."
  (let ((make-port (module-ref (resolve-interface '(lzlib)) proc)))
    (make-port port)))

(define (zstd-port proc port . args)
  "Return the zstd port produced by calling PROC (a symbol) on PORT and ARGS.
Raise an error if zstd support is missing."
  (let ((make-port (module-ref (resolve-interface '(zstd)) proc)))
    (make-port port)))

(define (decompressed-port compression input)
  "Return an input port where INPUT is decompressed according to COMPRESSION,
a symbol such as 'xz."
  (match compression
    ((or #f 'none) (values input '()))
    ('bzip2        (filtered-port `(,%bzip2 "-dc") input))
    ('xz           (filtered-port `(,%xz "-dc") input))
    ('gzip         (values (make-zlib-input-port input #:format 'gzip)
                           '()))
    ('lzip         (values (lzip-port 'make-lzip-input-port input)
                           '()))
    ('zstd         (values (zstd-port 'make-zstd-input-port input)
                           '()))
    (_             (error "unsupported compression scheme" compression))))

(define (call-with-decompressed-port compression port proc)
  "Call PROC with a wrapper around PORT, a file port, that decompresses data
read from PORT according to COMPRESSION, a symbol such as 'xz."
  (let-values (((decompressed pids)
                (decompressed-port compression port)))
    (dynamic-wind
      (const #f)
      (lambda ()
        (proc decompressed))
      (lambda ()
        (close-port decompressed)
        (unless (every (compose zero? cdr waitpid) pids)
          (error "decompressed-port failure" pids))))))

(define (filtered-output-port command output)
  "Return an output port.  Data written to that port is filtered through
COMMAND and written to OUTPUT, an output file port.  In addition, return a
list of PIDs to wait for.  OUTPUT must be unbuffered; otherwise, any buffered
data is lost."
  (match (pipe)
    ((in . out)
     (match (primitive-fork)
       (0
        (dynamic-wind
          (const #f)
          (lambda ()
            (close-port out)
            (close-port (current-input-port))
            (dup2 (fileno in) 0)
            (close-port (current-output-port))
            (dup2 (fileno output) 1)
            (catch 'system-error
              (lambda ()
                (apply execl (car command) command))
              (lambda args
                (format (current-error-port)
                        "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
                        command (strerror (system-error-errno args))))))
          (lambda ()
            (primitive-_exit 1))))
       (child
        (close-port in)
        (values out (list child)))))))

(define* (compressed-output-port compression output
                                 #:key (options '()))
  "Return an output port whose input is compressed according to COMPRESSION,
a symbol such as 'xz, and then written to OUTPUT.  In addition return a list
of PIDs to wait for.  OPTIONS is a list of strings passed to the compression
program--e.g., '(\"--fast\")."
  (match compression
    ((or #f 'none) (values output '()))
    ('bzip2        (filtered-output-port `(,%bzip2 "-c" ,@options) output))
    ('xz           (filtered-output-port `(,%xz "-c" ,@options) output))
    ('gzip         (values (make-zlib-output-port output #:format 'gzip)
                           '()))
    ('lzip         (values (lzip-port 'make-lzip-output-port output)
                           '()))
    ('zstd         (values (zstd-port 'make-zstd-output-port output)
                           '()))
    (_             (error "unsupported compression scheme" compression))))

(define* (call-with-compressed-output-port compression port proc
                                           #:key (options '()))
  "Call PROC with a wrapper around PORT, a file port, that compresses data
that goes to PORT according to COMPRESSION, a symbol such as 'xz.  OPTIONS is
a list of command-line arguments passed to the compression program."
  (let-values (((compressed pids)
                (compressed-output-port compression port
                                        #:options options)))
    (dynamic-wind
      (const #f)
      (lambda ()
        (proc compressed))
      (lambda ()
        (close-port compressed)
        (unless (every (compose zero? cdr waitpid) pids)
          (error "compressed-output-port failure" pids))))))

(define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
  "Edit the expression specified by SOURCE-PROPERTIES using PROC, which should
be a procedure that takes the original expression in string and returns a new
one.  ENCODING will be used to interpret all port I/O, it default to UTF-8.
This procedure returns #t on success."
  (with-fluids ((%default-port-encoding encoding))
    (let* ((file   (assq-ref source-properties 'filename))
           (line   (assq-ref source-properties 'line))
           (column (assq-ref source-properties 'column))
           (in     (open-input-file file))
           ;; The start byte position of the expression.
           (start  (begin (while (not (and (= line (port-line in))
                                           (= column (port-column in))))
                            (when (eof-object? (read-char in))
                              (error (format #f "~a: end of file~%" in))))
                          (ftell in)))
           ;; The end byte position of the expression.
           (end    (begin (read in) (ftell in))))
      (seek in 0 SEEK_SET) ; read from the beginning of the file.
      (let* ((pre-bv  (get-bytevector-n in start))
             ;; The expression in string form.
             (str     (iconv:bytevector->string
                       (get-bytevector-n in (- end start))
                       (port-encoding in)))
             (post-bv (get-bytevector-all in))
             (str*    (proc str)))
        ;; Verify the edited expression is still a scheme expression.
        (call-with-input-string str* read)
        ;; Update the file with edited expression.
        (with-atomic-file-output file
          (lambda (out)
            (put-bytevector out pre-bv)
            (display str* out)
            ;; post-bv maybe the end-of-file object.
            (when (not (eof-object? post-bv))
              (put-bytevector out post-bv))
            #t))))))

;;;
;;; Keyword arguments.
;;;

(define (strip-keyword-arguments keywords args)
  "Remove all of the keyword arguments listed in KEYWORDS from ARGS."
  (let loop ((args   args)
             (result '()))
    (match args
      (()
       (reverse result))
      (((? keyword? kw) arg . rest)
       (loop rest
             (if (memq kw keywords)
                 result
                 (cons* arg kw result))))
      ((head . tail)
       (loop tail (cons head result))))))

(define (default-keyword-arguments args defaults)
  "Return ARGS augmented with any keyword/value from DEFAULTS for
keywords not already present in ARGS."
  (let loop ((defaults defaults)
             (args     args))
    (match defaults
      ((kw value rest ...)
       (loop rest
             (if (memq kw args)
                 args
                 (cons* kw value args))))
      (()
       args))))

(define-syntax collect-default-args
  (syntax-rules ()
    ((_)
     '())
    ((_ (_ _) rest ...)
     (collect-default-args rest ...))
    ((_ (kw _ dflt) rest ...)
     (cons* kw dflt (collect-default-args rest ...)))))

(define-syntax substitute-keyword-arguments
  (syntax-rules ()
    "Return a new list of arguments where the value for keyword arg KW is
replaced by EXP.  EXP is evaluated in a context where VAR is bound to the
previous value of the keyword argument, or DFLT if given."
    ((_ original-args ((kw var dflt ...) exp) ...)
     (let loop ((args (default-keyword-arguments
                        original-args
                        (collect-default-args (kw var dflt ...) ...)))
                (before '()))
       (match args
         ((kw var rest (... ...))
          (loop rest (cons* exp kw before)))
         ...
         ((x rest (... ...))
          (loop rest (cons x before)))
         (()
          (reverse before)))))))

(define (delkw kw lst)
  "Remove KW and its associated value from LST, a keyword/value list such
as '(#:foo 1 #:bar 2)."
  (let loop ((lst    lst)
             (result '()))
    (match lst
      (()
       (reverse result))
      ((kw? value rest ...)
       (if (eq? kw? kw)
           (append (reverse result) rest)
           (loop rest (cons* value kw? result)))))))

(define (ensure-keyword-arguments args kw/values)
  "Force the keywords arguments KW/VALUES in the keyword argument list ARGS.
For instance:

  (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
  => (#:foo 2)

  (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
  => (#:foo 2 #:bar 3)

  (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))
  => (#:foo 42 #:bar 3)
"
  (let loop ((args      args)
             (kw/values kw/values)
             (result    '()))
    (match args
      (()
       (append (reverse result) kw/values))
      ((kw value rest ...)
       (match (memq kw kw/values)
         ((_ value . _)
          (loop rest (delkw kw kw/values) (cons* value kw result)))
         (#f
          (loop rest kw/values (cons* value kw result))))))))

;;;
;;; System strings.
;;;

(define* (nix-system->gnu-triplet
          #:optional (system (%current-system)) (vendor "unknown"))
  "Return a guess of the GNU triplet corresponding to Nix system
identifier SYSTEM."
  (match system
    ("armhf-linux"
     (string-append "arm-" vendor "-linux-gnueabihf"))
    (_
     (let* ((dash (string-index system #\-))
            (arch (substring system 0 dash))
            (os   (substring system (+ 1 dash))))
       (string-append arch
                      "-" vendor "-"
                      (if (string=? os "linux")
                          "linux-gnu"
                          os))))))

(define (gnu-triplet->nix-system triplet)
  "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
returned by `config.guess'."
  (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
                        =>
                        (lambda (m)
                          (string-append "i686-" (match:substring m 1))))
                       (else triplet))))
    (cond ((string-match "^arm[^-]*-([^-]+-)?linux-gnueabihf" triplet)
           "armhf-linux")
          ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
           =>
           (lambda (m)
             ;; Nix omits `-gnu' for GNU/Linux.
             (string-append (match:substring m 1) "-linux")))
          ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
           =>
           (lambda (m)
             ;; Nix strip the version number from names such as `gnu0.3',
             ;; `darwin10.2.0', etc., and always strips the vendor part.
             (string-append (match:substring m 1) "-"
                            (match:substring m 3))))
          (else triplet))))

(define %current-system
  ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
  ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
  (make-parameter %system))

(define %current-target-system
  ;; Either #f or a GNU triplet representing the target system we are
  ;; cross-building to.
  (make-parameter #f))

(define* (package-name->name+version spec
                                     #:optional (delimiter #\@))
  "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\"
and \"0.9.1b\".  When the version part is unavailable, SPEC and #f are
returned.  Both parts must not contain any '@'.  Optionally, DELIMITER can be
a character other than '@'."
  (match (string-rindex spec delimiter)
    (#f  (values spec #f))
    (idx (values (substring spec 0 idx)
                 (substring spec (1+ idx))))))

(define* (target-mingw? #:optional (target (%current-target-system)))
  (and target
       (string-suffix? "-mingw32" target)))

(define* (target-arm32? #:optional (target (or (%current-target-system)
                                               (%current-system))))
  (string-prefix? "arm" target))

(define* (target-aarch64? #:optional (target (or (%current-target-system)
                                                 (%current-system))))
  (string-prefix? "aarch64" target))

(define* (target-arm? #:optional (target (or (%current-target-system)
                                             (%current-system))))
  (or (target-arm32? target) (target-aarch64? target)))

(define* (target-powerpc? #:optional (target (or (%current-target-system)
                                                 (%current-system))))
  (string-prefix? "powerpc" target))

(define* (target-64bit? #:optional (system (or (%current-target-system)
                                               (%current-system))))
  (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64")))

(define* (cc-for-target #:optional (target (%current-target-system)))
  (if target
      (string-append target "-gcc")
      "gcc"))

(define* (cxx-for-target #:optional (target (%current-target-system)))
  (if target
      (string-append target "-g++")
      "g++"))

(define* (pkg-config-for-target #:optional (target (%current-target-system)))
  (if target
      (string-append target "-pkg-config")
      "pkg-config"))

(define version-compare
  (let ((strverscmp
         (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
                        (error "could not find `strverscmp' (from GNU libc)"))))
           (pointer->procedure int sym (list '* '*)))))
    (lambda (a b)
      "Return '> when A denotes a newer version than B,
'< when A denotes a older version than B,
or '= when they denote equal versions."
      (let ((result (strverscmp (string->pointer a) (string->pointer b))))
        (cond ((positive? result) '>)
              ((negative? result) '<)
              (else '=))))))

(define (version-prefix version-string num-parts)
  "Truncate version-string to the first num-parts components of the version.
For example, (version-prefix \"2.1.47.4.23\" 3) returns \"2.1.47\""
  (string-join (take (string-split version-string #\.) num-parts) "."))

(define (version-major+minor+point version-string)
  "Return \"major>.<minor>.<point>\", where major, minor and point are the
major, minor and point version numbers from the version-string.  For example,
(version-major+minor+point \"6.4.5.2\") returns \"6.4.5\" or
(version-major+minor+point \"1.19.2-2581-324ca14c3003\") returns \"1.19.2\"."
  (let* ((3-dot (version-prefix version-string 3))
         (index (string-index 3-dot #\-)))
    (or (false-if-exception (substring 3-dot 0 index))
        3-dot)))

(define (version-major+minor version-string)
  "Return \"<major>.<minor>\", where major and minor are the major and
minor version numbers from version-string."
  (version-prefix version-string 2))

(define (version-major version-string)
  "Return the major version number as string from the version-string."
  (version-prefix version-string 1))

(define (version-unique-prefix version versions)
  "Return the shortest version prefix to unambiguously identify VERSION among
VERSIONS.  For example:

  (version-unique-prefix \"2.0\" '(\"3.0\" \"2.0\"))
  => \"2\"

  (version-unique-prefix \"2.2\" '(\"3.0.5\" \"2.0.9\" \"2.2.7\"))
  => \"2.2\"

  (version-unique-prefix \"27.1\" '(\"27.1\"))
  => \"\"
"
  (define not-dot
    (char-set-complement (char-set #\.)))

  (define other-versions
    (delete version versions))

  (let loop ((prefix     '())
             (components (string-tokenize version not-dot)))
    (define prefix-str
      (string-join prefix "."))

    (if (any (cut string-prefix? prefix-str <>) other-versions)
        (match components
          ((head . tail)
           (loop `(,@prefix ,head) tail))
          (()
           version))
        prefix-str)))

(define (version>? a b)
  "Return #t when A denotes a version strictly newer than B."
  (eq? '> (version-compare a b)))

(define (version>=? a b)
  "Return #t when A denotes a version newer or equal to B."
  (case (version-compare a b)
    ((> =) #t)
    (else #f)))

(define (guile-version>? str)
  "Return #t if the running Guile version is greater than STR."
  ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
  ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
  (version>? (string-append (major-version) "."
                            (minor-version) "."
                            (micro-version))
             str))

(define version-prefix?
  (let ((not-dot (char-set-complement (char-set #\.))))
    (lambda (v1 v2)
      "Return true if V1 is a version prefix of V2:

  (version-prefix? \"4.1\" \"4.16.2\") => #f
  (version-prefix? \"4.1\" \"4.1.2\") => #t
"
      (define (list-prefix? lst1 lst2)
        (match lst1
          (() #t)
          ((head1 tail1 ...)
           (match lst2
             (() #f)
             ((head2 tail2 ...)
              (and (equal? head1 head2)
                   (list-prefix? tail1 tail2)))))))

      (list-prefix? (string-tokenize v1 not-dot)
                    (string-tokenize v2 not-dot)))))

;;;
;;; Files.
;;;

(define (file-extension file)
  "Return the extension of FILE or #f if there is none."
  (let ((dot (string-rindex file #\.)))
    (and dot (substring file (+ 1 dot) (string-length file)))))

(define (file-sans-extension file)
  "Return the substring of FILE without its extension, if any."
  (let ((dot (string-rindex file #\.)))
    (if dot
        (substring file 0 dot)
        file)))

(define (tarball-sans-extension tarball)
  "Return TARBALL without its .tar.* or .zip extension."
  (let ((end (or (string-contains tarball ".tar")
                 (string-contains tarball ".tgz")
                 (string-contains tarball ".zip"))))
    (substring tarball 0 end)))

(define (compressed-file? file)
  "Return true if FILE denotes a compressed file."
  (->bool (member (file-extension file)
                  '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "zip"))))

(define (switch-symlinks link target)
  "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
both when LINK already exists and when it does not."
  (let ((pivot (string-append link ".new")))
    (symlink target pivot)
    (rename-file pivot link)))

(define* (string-replace-substring str substr replacement
                                   #:optional
                                   (start 0)
                                   (end (string-length str)))
  "Replace all occurrences of SUBSTR in the START--END range of STR by
REPLACEMENT."
  (match (string-length substr)
    (0
     (error "string-replace-substring: empty substring"))
    (substr-length
     (let loop ((start  start)
                (pieces (list (substring str 0 start))))
       (match (string-contains str substr start end)
         (#f
          (string-concatenate-reverse
           (cons (substring str start) pieces)))
         (index
          (loop (+ index substr-length)
                (cons* replacement
                       (substring str start index)
                       pieces))))))))

(define (call-with-temporary-output-file proc)
  "Call PROC with a name of a temporary file and open output port to that
file; close the file and delete it when leaving the dynamic extent of this
call."
  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
         (template  (string-append directory "/guix-file.XXXXXX"))
         (out       (mkstemp! template)))
    (dynamic-wind
      (lambda ()
        #t)
      (lambda ()
        (proc template out))
      (lambda ()
        (false-if-exception (close out))
        (false-if-exception (delete-file template))))))

(define (call-with-temporary-directory proc)
  "Call PROC with a name of a temporary directory; close the directory and
delete it when leaving the dynamic extent of this call."
  (let* ((directory (or (getenv "TMPDIR") "/tmp"))
         (template  (string-append directory "/guix-directory.XXXXXX"))
         (tmp-dir   (mkdtemp! template)))
    (dynamic-wind
      (const #t)
      (lambda ()
        (proc tmp-dir))
      (lambda ()
        (false-if-exception (delete-file-recursively tmp-dir))))))

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

(define* (xdg-directory variable suffix #:key (ensure? #t))
  "Return the name of the XDG directory that matches VARIABLE and SUFFIX,
after making sure that it exists if ENSURE? is true.  VARIABLE is an
environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
\"/.config\".  Honor the XDG specs,
<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
  (let ((dir (and=> (or (getenv variable)
                        (and=> (or (getenv "HOME")
                                   (passwd:dir (getpwuid (getuid))))
                               (cut string-append <> suffix)))
                    (cut string-append <> "/guix"))))
    (when ensure?
      (mkdir-p dir))
    dir))

(define config-directory
  (cut xdg-directory "XDG_CONFIG_HOME" "/.config" <...>))

(define cache-directory
  (cut xdg-directory "XDG_CACHE_HOME" "/.cache" <...>))

(define (readlink* file)
  "Call 'readlink' until the result is not a symlink."
  (define %max-symlink-depth 50)

  (let loop ((file  file)
             (depth 0))
    (define (absolute target)
      (if (absolute-file-name? target)
          target
          (string-append (dirname file) "/" target)))

    (if (>= depth %max-symlink-depth)
        file
        (call-with-values
            (lambda ()
              (catch 'system-error
                (lambda ()
                  (values #t (readlink file)))
                (lambda args
                  (let ((errno (system-error-errno args)))
                    (if (or (= errno EINVAL))
                        (values #f file)
                        (apply throw args))))))
          (lambda (success? target)
            (if success?
                (loop (absolute target) (+ depth 1))
                file))))))

(define (canonical-newline-port port)
  "Return an input port that wraps PORT such that all newlines consist
  of a single linefeed."
  (define (get-position)
    (if (port-has-port-position? port) (port-position port) #f))
  (define (set-position! position)
    (if (port-has-set-port-position!? port)
        (set-port-position! position port)
        #f))
  (define (close) (close-port port))
  (define (read! bv start n)
    (let loop ((count 0)
               (byte (get-u8 port)))
      (cond ((eof-object? byte) count)
            ;; XXX: consume all CRs even if not followed by LF.
            ((eqv? byte (char->integer #\return)) (loop count (get-u8 port)))
            ((= count (- n 1))
             (bytevector-u8-set! bv (+ start count) byte)
             n)
            (else
             (bytevector-u8-set! bv (+ start count) byte)
             (loop (+ count 1) (get-u8 port))))))
  (make-custom-binary-input-port "canonical-newline-port"
                                 read!
                                 get-position
                                 set-position!
                                 close))

;;;
;;; Source location.
;;;

(define absolute-dirname
  ;; Memoize to avoid repeated 'stat' storms from 'search-path'.
  (mlambda (file)
    "Return the absolute name of the directory containing FILE, or #f upon
failure."
    (match (search-path %load-path file)
      (#f #f)
      ((? string? file)
       ;; If there are relative names in %LOAD-PATH, FILE can be relative and
       ;; needs to be canonicalized.
       (if (string-prefix? "/" file)
           (dirname file)
           (canonicalize-path (dirname file)))))))

(define-syntax current-source-directory
  (lambda (s)
    "Return the absolute name of the current directory, or #f if it could not
be determined."
    (syntax-case s ()
      ((_)
       (match (assq 'filename (or (syntax-source s) '()))
         (('filename . (? string? file-name))
          ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME
          ;; can be relative.  In that case, we try to find out at run time
          ;; the absolute file name by looking at %LOAD-PATH; doing this at
          ;; run time rather than expansion time is necessary to allow files
          ;; to be moved on the file system.
          (if (string-prefix? "/" file-name)
              (dirname file-name)
              #`(absolute-dirname #,file-name)))
         ((or ('filename . #f) #f)
          ;; raising an error would upset Geiser users
          #f))))))

;;;
;;; String comparison.
;;;

(define (string-distance s1 s2)
  "Compute the Levenshtein distance between two strings."
  ;; Naive implemenation
  (define loop
    (mlambda (as bt)
      (match as
        (() (length bt))
        ((a s ...)
         (match bt
           (() (length as))
           ((b t ...)
            (if (char=? a b)
                (loop s t)
                (1+ (min
                     (loop as t)
                     (loop s bt)
                     (loop s t))))))))))

  (let ((c1 (string->list s1))
        (c2 (string->list s2)))
    (loop c1 c2)))

(define* (string-closest trial tests #:key (threshold 3))
  "Return the string from TESTS that is the closest from the TRIAL,
according to 'string-distance'.  If the TESTS are too far from TRIAL,
according to THRESHOLD, then #f is returned."
  (identity                              ;discard second return value
    (fold2 (lambda (test closest minimal)
             (let ((dist (string-distance trial test)))
               (if (and  (< dist minimal) (< dist threshold))
                   (values test dist)
                   (values closest minimal))))
           #f +inf.0
           tests)))

;;;
;;; Prettified output.
;;;

(define* (pretty-print-table rows #:key (max-column-width 20))
  "Print ROWS in neat columns.  All rows should be lists of strings and each
row should have the same length.  The columns are separated by a tab
character, and aligned using spaces.  The maximum width of each column is
bound by MAX-COLUMN-WIDTH."
  (let* ((number-of-columns-to-pad (if (null? rows)
                                       0
                                       (1- (length (first rows)))))
         ;; Ignore the last column as it is left aligned and doesn't need
         ;; padding; this prevents printing extraneous trailing spaces.
         (column-widths (fold (lambda (row maximums)
                                (map max (map string-length row) maximums))
                              ;; Initial max width is 0 for each column.
                              (make-list number-of-columns-to-pad 0)
                              (map (cut drop-right <> 1) rows)))
         (column-formats (map (cut format #f "~~~da" <>)
                              (map (cut min <> max-column-width)
                                   column-widths)))
         (fmt (string-append (string-join column-formats "\t") "\t~a")))
    (for-each (cut format #t "~?~%" fmt <>) rows)))

;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 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 workers)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 match)
  #:use-module (ice-9 q)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module ((guix build syscalls) #:select (set-thread-name))
  #:export (pool?
            make-pool
            pool-enqueue!
            pool-idle?
            eventually))

;;; Commentary:
;;;
;;; This module implements "worker pools".  Worker pools are the low-level
;;; mechanism that's behind futures: there's a fixed set of threads
;;; ("workers") that one can submit work to, and one of them will eventually
;;; pick the submitted tasks.
;;;
;;; Unlike futures, these worker pools are meant to be used for tasks that
;;; have a side-effect.  Thus, we never "touch" a task that was submitted like
;;; we "touch" a future.  Instead, we simply assume that the task will
;;; eventually complete.
;;;
;;; Code:

(define-record-type <pool>
  (%make-pool queue mutex condvar workers busy)
  pool?
  (queue    pool-queue)
  (mutex    pool-mutex)
  (condvar  pool-condition-variable)
  (workers  pool-workers)
  (busy     pool-busy))

(define-syntax-rule (without-mutex mutex exp ...)
  (dynamic-wind
    (lambda ()
      (unlock-mutex mutex))
    (lambda ()
      exp ...)
    (lambda ()
      (lock-mutex mutex))))

(define* (worker-thunk mutex condvar pop-queue
                       #:key idle busy (thread-name "guix worker"))
  "Return the thunk executed by worker threads."
  (define (loop)
    (match (pop-queue)
      (#f                                         ;empty queue
       (idle)
       (wait-condition-variable condvar mutex)
       (busy))
      ((? procedure? proc)
       ;; Release MUTEX while executing PROC.
       (without-mutex mutex
         (catch #t proc
           (const #f)
           (lambda (key . args)
             ;; XXX: In Guile 2.0 ports are not thread-safe, so this could
             ;; crash (Guile 2.2 is fine).
             (display-backtrace (make-stack #t) (current-error-port))
             (print-exception (current-error-port)
                              (and=> (make-stack #t)
                                     (cut stack-ref <> 0))
                              key args))))))
    (loop))

  (lambda ()
    (catch 'system-error
      (lambda ()
        (set-thread-name thread-name))
      (const #f))

    (with-mutex mutex
      (loop))))

(define* (make-pool #:optional (count (current-processor-count))
                    #:key (thread-name "guix worker"))
  "Return a pool of COUNT workers.  Use THREAD-NAME as the name of these
threads as reported by the operating system."
  (let* ((mutex   (make-mutex))
         (condvar (make-condition-variable))
         (queue   (make-q))
         (busy    count)
         (procs   (unfold (cut >= <> count)
                          (lambda (n)
                            (worker-thunk mutex condvar
                                          (lambda ()
                                            (and (not (q-empty? queue))
                                                 (q-pop! queue)))
                                          #:busy (lambda ()
                                                   (set! busy (+ 1 busy)))
                                          #:idle (lambda ()
                                                   (set! busy (- busy 1)))
                                          #:thread-name thread-name))
                          1+
                          0))
         (threads (map (lambda (proc)
                         (call-with-new-thread proc))
                       procs)))
    (%make-pool queue mutex condvar threads (lambda () busy))))

(define (pool-enqueue! pool thunk)
  "Enqueue THUNK for future execution by POOL."
  (with-mutex (pool-mutex pool)
    (enq! (pool-queue pool) thunk)
    (signal-condition-variable (pool-condition-variable pool))))

(define (pool-idle? pool)
  "Return true if POOL doesn't have any task in its queue and all the workers
are currently idle (i.e., waiting for a task)."
  (with-mutex (pool-mutex pool)
    (and (q-empty? (pool-queue pool))
         (zero? ((pool-busy pool))))))

(define-syntax-rule (eventually pool exp ...)
  "Run EXP eventually on one of the workers of POOL."
  (pool-enqueue! pool (lambda () exp ...)))

;;; Local Variables:
;;; eval: (put 'without-mutex 'scheme-indent-function 1)
;;; End:

;;; workers.scm ends here


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

dnl GUIX_SYSTEM_TYPE
dnl
dnl Determine the Guix host system type, and store it in the
dnl `guix_system' variable.
AC_DEFUN([GUIX_SYSTEM_TYPE], [
  AC_REQUIRE([AC_CANONICAL_HOST])
  AC_PATH_PROG([SED], [sed])

  AC_ARG_WITH(system, AS_HELP_STRING([--with-system=SYSTEM],
    [Platform identifier (e.g., `i686-linux').]),
    [guix_system="$withval"],
    [case "$host_cpu" in
       i*86)
	  machine_name="i686";;
       amd64)
          machine_name="x86_64";;
       arm|armv[[7-9]]*)
          # Here we want to exclude CPUs such as "armv6l".  On ARMv7
          # machines, we normally get "armv7l".  However, in Guix, we
          # configure with --build=arm-unknown-linux-gnueabihf, leading
          # to just "arm", so we also have to allow it.
          #
          # TODO: If not cross-compiling, add a sanity check to make
          #       sure this build machine has the needed features to
          #       support executables compiled using our armhf gcc,
          #       configured with:
          #         --with-arch=armv7-a
          #         --with-float=hard
          #         --with-mode=thumb
          #         --with-fpu=vfpv3-d16
	  machine_name="armhf";;
       *)
	  machine_name="$host_cpu";;
     esac

     case "$host_os" in
       linux-gnu*)
	  # For backward compatibility, strip the `-gnu' part.
	  guix_system="$machine_name-linux";;
       gnu*)
          # Always use i586 for GNU/Hurd.
          guix_system="i586-gnu";;
       *)
	  # Strip the version number from names such as `gnu0.3',
	  # `darwin10.2.0', etc.
	  guix_system="$machine_name-`echo $host_os | "$SED" -e's/[0-9.]*$//g'`";;
     esac])

  AC_MSG_CHECKING([for the Guix system type])
  AC_MSG_RESULT([$guix_system])

  AC_SUBST([guix_system])
])

dnl GUIX_ASSERT_SUPPORTED_SYSTEM
dnl
dnl Assert that this is a system to which the distro is ported.
AC_DEFUN([GUIX_ASSERT_SUPPORTED_SYSTEM], [
  AC_REQUIRE([GUIX_SYSTEM_TYPE])

  AC_ARG_WITH([courage], [AS_HELP_STRING([--with-courage],
    [Assert that even if this platform is unsupported, you will be
courageous and port the GNU System distribution to it (see
"GNU Distribution" in the manual.)])],
    [guix_courageous="$withval"],
    [guix_courageous="no"])

  # Currently only Linux-based systems are supported, and only on some
  # platforms.
  case "$guix_system" in
    x86_64-linux|i686-linux|armhf-linux|aarch64-linux|powerpc64le-linux)
      ;;
    *)
      if test "x$guix_courageous" = "xyes"; then
        AC_MSG_WARN([building Guix on `$guix_system', which is not supported])
      else
        AC_MSG_ERROR([`$guix_system' is not a supported platform.
See "GNU Distribution" in the manual, or try `--with-courage'.])
      fi
      ;;
  esac
])

dnl GUIX_ASSERT_GUILE_FEATURES FEATURES
dnl
dnl Assert that FEATURES are provided by $GUILE.
AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [
  for guix_guile_feature in $1
  do
    AC_MSG_CHECKING([whether $GUILE provides feature '$guix_guile_feature'])
    if "$GUILE" -c "(exit (provided? '$guix_guile_feature))"
    then
      AC_MSG_RESULT([yes])
    else
      AC_MSG_RESULT([no])
      AC_MSG_ERROR([$GUILE does not support feature '$guix_guile_feature', which is required.])
    fi
  done
])

dnl GUIX_CHECK_GUILE_SSH
dnl
dnl Check whether a recent-enough Guile-SSH is available.
AC_DEFUN([GUIX_CHECK_GUILE_SSH], [
  dnl Check whether '#:nodelay' paramater to 'make-session' (introduced in
  dnl 0.13.0) is present.
  AC_CACHE_CHECK([whether Guile-SSH is available and recent enough],
    [guix_cv_have_recent_guile_ssh],
    [GUILE_CHECK([retval],
      [(and (@ (ssh channel) channel-send-eof)
            (@ (ssh popen) open-remote-pipe)
            (@ (ssh dist node) node-eval)
            (@ (ssh auth) userauth-gssapi!)
            ((@ (ssh session) make-session) #:nodelay #t))])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_ssh="yes"
     else
       guix_cv_have_recent_guile_ssh="no"
     fi])
])

dnl GUIX_CHECK_GUILE_SQLITE3
dnl
dnl Check whether a recent-enough Guile-Sqlite3 is available.
AC_DEFUN([GUIX_CHECK_GUILE_SQLITE3], [
  dnl Check whether 'sqlite-bind-arguments' is available.  It was introduced
  dnl in February 2018:
  dnl <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/1cd1dec96a9999db48c0ff45bab907efc637247f>.
  AC_CACHE_CHECK([whether Guile-Sqlite3 is available and recent enough],
    [guix_cv_have_recent_guile_sqlite3],
    [GUILE_CHECK([retval],
      [(@ (sqlite3) sqlite-bind-arguments)])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_sqlite3="yes"
     else
       guix_cv_have_recent_guile_sqlite3="no"
     fi])
])

dnl GUIX_CHECK_GUILE_JSON
dnl
dnl Check whether a recent-enough Guile-JSON is available.
AC_DEFUN([GUIX_CHECK_GUILE_JSON], [
  dnl Check whether we're using Guile-JSON 4.3+, which provides
  dnl 'define-json-mapping'.
  AC_CACHE_CHECK([whether Guile-JSON is available and recent enough],
    [guix_cv_have_recent_guile_json],
    [GUILE_CHECK([retval],
      [(use-modules (json))

       (define-json-mapping <frob> make-frob
         frob?
	 json->frob
	 (a frob-a)
	 (b frob-b \"bee\"))

       (exit
        (equal? (json->frob
                 (open-input-string \"{ \\\"a\\\": 1, \\\"bee\\\": 2 }\"))
                (make-frob 1 2)))])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_json="yes"
     else
       guix_cv_have_recent_guile_json="no"
     fi])
])

dnl GUIX_CHECK_GUILE_GCRYPT
dnl
dnl Check whether a recent-enough Guile-Gcrypt is available.
AC_DEFUN([GUIX_CHECK_GUILE_GCRYPT], [
  dnl Check whether we're using Guile-Gcrypt 0.2.x or later.  0.2.0
  dnl introduced the 'hash-algorithm' macro and related code.
  AC_CACHE_CHECK([whether Guile-Gcrypt is available and recent enough],
    [guix_cv_have_recent_guile_gcrypt],
    [GUILE_CHECK([retval],
      [(use-modules (gcrypt hash))
       (equal? (hash-algorithm sha256)
               (lookup-hash-algorithm 'sha256))])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_gcrypt="yes"
     else
       guix_cv_have_recent_guile_gcrypt="no"
     fi])
])

dnl GUIX_CHECK_GUILE_GIT
dnl
dnl Check whether a recent-enough Guile-Git is available.
AC_DEFUN([GUIX_CHECK_GUILE_GIT], [
  dnl Check whether we're using Guile-Git 0.3.0 or later.  0.3.0
  dnl introduced SSH authentication support and more.
  AC_CACHE_CHECK([whether Guile-Git is available and recent enough],
    [guix_cv_have_recent_guile_git],
    [GUILE_CHECK([retval],
      [(use-modules (git) (git auth) (git submodule))
       (let ((auth (%make-auth-ssh-agent)))
         repository-close!
	 object-lookup-prefix
         (make-clone-options
          #:fetch-options (make-fetch-options auth)))])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_git="yes"
     else
       guix_cv_have_recent_guile_git="no"
     fi])
])

dnl GUIX_CHECK_GUILE_ZLIB
dnl
dnl Check whether a recent-enough Guile-zlib is available.
AC_DEFUN([GUIX_CHECK_GUILE_ZLIB], [
  dnl Check whether we're using Guile-zlib 0.1.0 or later.
  dnl 0.1.0 introduced the 'make-zlib-input-port' and related code.
  AC_CACHE_CHECK([whether Guile-zlib is available and recent enough],
    [guix_cv_have_recent_guile_zlib],
    [GUILE_CHECK([retval],
      [(use-modules (zlib))
       make-zlib-input-port])
     if test "$retval" = 0; then
       guix_cv_have_recent_guile_zlib="yes"
     else
       guix_cv_have_recent_guile_zlib="no"
     fi])
])

dnl GUIX_TEST_ROOT_DIRECTORY
AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
  AC_CACHE_CHECK([for unit test root directory],
    [ac_cv_guix_test_root],
    [ac_cv_guix_test_root="`pwd`/test-tmp"])
])

dnl 'BINPRM_BUF_SIZE' constant in Linux (we leave room for the trailing zero.)
dnl The Hurd has a limit of about a page (see exec/hashexec.c.)
m4_define([LINUX_HASH_BANG_LIMIT], 127)

dnl Hardcoded 'sun_path' length in <sys/un.h>.
m4_define([SOCKET_FILE_NAME_LIMIT], 108)

dnl GUIX_SOCKET_FILE_NAME_LENGTH
AC_DEFUN([GUIX_SOCKET_FILE_NAME_LENGTH], [
  AC_CACHE_CHECK([the length of the installed socket file name],
    [ac_cv_guix_socket_file_name_length],
    [ac_cv_guix_socket_file_name_length="`echo -n "$guix_localstatedir/guix/daemon-socket/socket" | wc -c`"])
])

dnl GUIX_TEST_SOCKET_FILE_NAME_LENGTH
AC_DEFUN([GUIX_TEST_SOCKET_FILE_NAME_LENGTH], [
  AC_REQUIRE([GUIX_TEST_ROOT_DIRECTORY])
  AC_CACHE_CHECK([the length of the socket file name used in tests],
    [ac_cv_guix_test_socket_file_name_length],
    [ac_cv_guix_test_socket_file_name_length="`echo -n "$ac_cv_guix_test_root/var/123456/daemon-socket/socket" | wc -c`"])
])

dnl GUIX_HASH_BANG_LENGTH
AC_DEFUN([GUIX_HASH_BANG_LENGTH], [
  AC_CACHE_CHECK([the length of a typical hash bang line],
    [ac_cv_guix_hash_bang_length],
    [ac_cv_guix_hash_bang_length=`echo -n "$storedir/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bootstrap-binaries-0/bin/bash" | wc -c`])
])

dnl GUIX_TEST_HASH_BANG_LENGTH
AC_DEFUN([GUIX_TEST_HASH_BANG_LENGTH], [
  AC_REQUIRE([GUIX_TEST_ROOT_DIRECTORY])
  AC_CACHE_CHECK([the length of a hash bang line used in tests],
    [ac_cv_guix_test_hash_bang_length],
    [ac_cv_guix_test_hash_bang_length=`echo -n "$ac_cv_guix_test_root/store/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bootstrap-binaries-0/bin/bash" | wc -c`])
])

dnl GUIX_CHECK_FILE_NAME_LIMITS
dnl
dnl GNU/Linux has a couple of silly limits that we can easily run into.
dnl Make sure everything is fine with the current settings.  Set $1 to
dnl 'yes' if tests can run, 'no' otherwise.
AC_DEFUN([GUIX_CHECK_FILE_NAME_LIMITS], [
  AC_REQUIRE([GUIX_SOCKET_FILE_NAME_LENGTH])
  AC_REQUIRE([GUIX_TEST_SOCKET_FILE_NAME_LENGTH])
  AC_REQUIRE([GUIX_HASH_BANG_LENGTH])
  AC_REQUIRE([GUIX_TEST_HASH_BANG_LENGTH])

  if test "$ac_cv_guix_socket_file_name_length" -ge ]SOCKET_FILE_NAME_LIMIT[; then
    AC_MSG_ERROR([socket file name would exceed the maxium allowed length])
  fi
  if test "$ac_cv_guix_test_socket_file_name_length" -ge ]SOCKET_FILE_NAME_LIMIT[; then
    AC_MSG_WARN([socket file name limit may be exceeded when running tests])
  fi

  $1=yes
  if test "$ac_cv_guix_hash_bang_length" -ge ]LINUX_HASH_BANG_LIMIT[; then
    $1=no
    AC_MSG_ERROR([store directory '$storedir' would lead to overly long hash-bang lines])
  fi
  if test "$ac_cv_guix_test_hash_bang_length" -ge ]LINUX_HASH_BANG_LIMIT[; then
    $1=no
    AC_MSG_WARN([test directory '$ac_cv_guix_test_root' may lead to overly long hash-bang lines])
  fi
])

dnl GUIX_CHECK_CXX11
dnl
dnl Check whether the C++ compiler can compile a typical C++11 program.
AC_DEFUN([GUIX_CHECK_CXX11], [
  AC_REQUIRE([AC_PROG_CXX])
  AC_CACHE_CHECK([whether $CXX supports C++11],
    [ac_cv_guix_cxx11_support],
    [save_CXXFLAGS="$CXXFLAGS"
     CXXFLAGS="-std=c++11 $CXXFLAGS"
     AC_COMPILE_IFELSE([
      AC_LANG_SOURCE([
	#include <functional>

	std::function<int(int)>
	return_plus_lambda (int x)
	{
	  auto result = [[&]](int y) {
	    return x + y;
	  };

	  return result;
	}
      ])],
      [ac_cv_guix_cxx11_support=yes],
      [ac_cv_guix_cxx11_support=no])
    CXXFLAGS="$save_CXXFLAGS"
  ])
])

dnl GUIX_ASSERT_CXX11
dnl
dnl Error out if the C++ compiler cannot compile C++11 code.
AC_DEFUN([GUIX_ASSERT_CXX11], [
  GUIX_CHECK_CXX11
  if test "x$ac_cv_guix_cxx11_support" != "xyes"; then
    AC_MSG_ERROR([C++ compiler '$CXX' does not support the C++11 standard])
  fi
])

dnl GUIX_LIBGCRYPT_LIBDIR VAR
dnl
dnl Attempt to determine libgcrypt's LIBDIR; store the result in VAR.
AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [
  AC_PATH_PROG([LIBGCRYPT_CONFIG], [libgcrypt-config])
  AC_CACHE_CHECK([libgcrypt's library directory],
    [guix_cv_libgcrypt_libdir],
    [if test "x$LIBGCRYPT_CONFIG" != "x"; then
       guix_cv_libgcrypt_libdir=`$LIBGCRYPT_CONFIG --libs | grep -e -L | sed -e "s/.*-L\([[^ ]]\+\)[[[:blank:]]]\+-lgcrypt.*/\1/g"`
     else
       guix_cv_libgcrypt_libdir=""
     fi])
  $1="$guix_cv_libgcrypt_libdir"
])

dnl GUIX_CURRENT_LOCALSTATEDIR
dnl
dnl Determine the localstatedir of an existing Guix installation and set
dnl 'guix_cv_current_localstatedir' accordingly.  Set it to "none" if no
dnl existing installation was found.
AC_DEFUN([GUIX_CURRENT_LOCALSTATEDIR], [
  AC_PATH_PROG([GUILE], [guile])
  AC_CACHE_CHECK([the current installation's localstatedir],
    [guix_cv_current_localstatedir],
    [dnl Call 'dirname' because (guix config) appends "/guix" to LOCALSTATEDIR.
     guix_cv_current_localstatedir="`"$GUILE" \
       -c '(use-modules (guix config))
           (when (string=? %store-directory "'$storedir'")
             (display (dirname %state-directory)))' \
       2>/dev/null`"
     if test "x$guix_cv_current_localstatedir" = "x"; then
       guix_cv_current_localstatedir=none
     fi])])

dnl GUIX_CHECK_LOCALSTATEDIR
dnl
dnl Check that the LOCALSTATEDIR value is consistent with that of the existing
dnl Guix installation, if any.  Error out or warn if they do not match.
AC_DEFUN([GUIX_CHECK_LOCALSTATEDIR], [
  AC_REQUIRE([GUIX_CURRENT_LOCALSTATEDIR])
  if test "x$guix_cv_current_localstatedir" != "xnone"; then
    if test "$guix_cv_current_localstatedir" != "$guix_localstatedir"; then
      case "$localstatedir" in
        NONE|\${prefix}*)
          # User kept the default value---i.e., did not pass '--localstatedir'.
          AC_MSG_ERROR([chosen localstatedir '$guix_localstatedir' does not match \
that of the existing installation '$guix_cv_current_localstatedir'
Installing may corrupt $storedir!
Use './configure --localstatedir=$guix_cv_current_localstatedir'.])
          ;;
        *)
          # User passed an explicit '--localstatedir'.  Assume they know what
          # they're doing.
          AC_MSG_WARN([chosen localstatedir '$guix_localstatedir' does not match \
that of the existing installation '$guix_cv_current_localstatedir'])
          AC_MSG_WARN([installing may corrupt $storedir!])
         ;;
      esac
    fi
  fi])

dnl GUIX_CHANNEL_METADATA
dnl
dnl Provide the channel metadata for this build.  This allows 'guix describe'
dnl to return meaningful data, as it would for a 'guix pull'-provided 'guix'.
dnl The default URL and introduction are taken from (guix channels).
AC_DEFUN([GUIX_CHANNEL_METADATA], [
  AC_ARG_WITH([channel-url], [AS_HELP_STRING([--with-channel-url=URL],
    [assert that this is built from the Git repository at URL])],
    [guix_channel_url="\"$withval\""],
    [guix_channel_url="\"https://git.savannah.gnu.org/git/guix.git\""])
  AC_ARG_WITH([channel-commit], [AS_HELP_STRING([--with-channel-commit=COMMIT],
    [assert that this is built from COMMIT])],
    [guix_channel_commit="\"$withval\""],
    [guix_channel_commit="#f"])
  AC_ARG_WITH([channel-introduction], [AS_HELP_STRING([--with-channel-introduction=COMMIT:FINGERPRINT],
    [specify COMMIT and FINGERPRINT as the introduction of this channel])],
    [guix_channel_introduction="'(\"`echo $withval | cut -f1 -d:`\" \"`echo $withval | cut -f2 -d:`\")"],
    [guix_channel_introduction="'(\"9edb3f66fd807b096b48283debdcddccfea34bad\" . \"BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA\")"])

  GUIX_CHANNEL_URL="$guix_channel_url"
  GUIX_CHANNEL_COMMIT="$guix_channel_commit"
  GUIX_CHANNEL_INTRODUCTION="$guix_channel_introduction"

  AC_SUBST([GUIX_CHANNEL_URL])
  AC_SUBST([GUIX_CHANNEL_COMMIT])
  AC_SUBST([GUIX_CHANNEL_INTRODUCTION])
])


code:
Most of the code is this directory was written by several people for
the Nix project (http://nixos.org/nix).  Thanks!

path: nix/AUTHORS


code:
//
//  boost/assert.hpp - BOOST_ASSERT(expr)
//
//  Copyright (c) 2001, 2002 Peter Dimov and Multi Media Ltd.
//
//  Permission to copy, use, modify, sell and distribute this software
//  is granted provided this copyright notice appears in all copies.
//  This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.
//
//  Note: There are no include guards. This is intentional.
//
//  See http://www.boost.org/libs/utility/assert.html for documentation.
//

#undef BOOST_ASSERT

#if defined(BOOST_DISABLE_ASSERTS)

# define BOOST_ASSERT(expr) ((void)0)

#elif defined(BOOST_ENABLE_ASSERT_HANDLER)

#include <boost/current_function.hpp>

namespace boost
{

void assertion_failed(char const * expr, char const * function, char const * file, long line); // user defined

} // namespace boost

#define BOOST_ASSERT(expr) ((expr)? ((void)0): ::boost::assertion_failed(#expr, BOOST_CURRENT_FUNCTION, __FILE__, __LINE__))

#else
# include <assert.h>
# define BOOST_ASSERT(expr) assert(expr)
#endif


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream

// ----------------------------------------------------------------------------
// format.hpp :  primary header
// ----------------------------------------------------------------------------

#ifndef BOOST_FORMAT_HPP
#define BOOST_FORMAT_HPP

#include <vector>
#include <string>
#include <sstream>
#include <cassert>

#if HAVE_LOCALE
#include <locale>
#else
#define BOOST_NO_STD_LOCALE
#define BOOST_NO_LOCALE_ISIDIGIT
#include <cctype>
#endif

#include <boost/format/macros_default.hpp>

// ****  Forward declarations ----------------------------------
#include <boost/format/format_fwd.hpp>           // basic_format<Ch,Tr>, and other frontends
#include <boost/format/internals_fwd.hpp>        // misc forward declarations for internal use

// ****  Auxiliary structs (stream_format_state<Ch,Tr> , and format_item<Ch,Tr> )
#include <boost/format/internals.hpp>

// ****  Format  class  interface --------------------------------
#include <boost/format/format_class.hpp>

// **** Exceptions -----------------------------------------------
#include <boost/format/exceptions.hpp>

// **** Implementation -------------------------------------------
//#include <boost/format/format_implementation.hpp>   // member functions

#include <boost/format/group.hpp>                   // class for grouping arguments

#include <boost/format/feed_args.hpp>               // argument-feeding functions
//#include <boost/format/parsing.hpp>                 // format-string parsing (member-)functions

// **** Implementation of the free functions ----------------------
//#include <boost/format/free_funcs.hpp>

#endif // BOOST_FORMAT_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// exceptions.hpp
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_EXCEPTIONS_HPP
#define BOOST_FORMAT_EXCEPTIONS_HPP

#include <stdexcept>

namespace boost {

namespace io {

// **** exceptions -----------------------------------------------

class format_error : public std::exception
{
public:
  format_error() {}
  virtual const char *what() const throw()
  {
    return "boost::format_error: "
      "format generic failure";
  }
};

class bad_format_string : public format_error
{
public:
  bad_format_string() {}
  virtual const char *what() const throw()
  {
    return "boost::bad_format_string: "
      "format-string is ill-formed";
  }
};

class too_few_args : public format_error
{
public:
  too_few_args() {}
  virtual const char *what() const throw()
  {
    return "boost::too_few_args: "
      "format-string referred to more arguments than were passed";
  }
};

class too_many_args : public format_error
{
public:
  too_many_args() {}
  virtual const char *what() const throw()
  {
    return "boost::too_many_args: "
      "format-string referred to less arguments than were passed";
  }
};

class  out_of_range : public format_error
{
public:
  out_of_range() {}
  virtual const char *what() const throw()
  {
    return "boost::out_of_range: "
      "tried to refer to an argument (or item) number which is out of range, "
      "according to the format string.";
  }
};

} // namespace io

} // namespace boost

#endif // BOOST_FORMAT_EXCEPTIONS_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream

// ----------------------------------------------------------------------------
// feed_args.hpp :  functions for processing each argument
//                      (feed, feed_manip, and distribute)
// ----------------------------------------------------------------------------

#ifndef BOOST_FORMAT_FEED_ARGS_HPP
#define BOOST_FORMAT_FEED_ARGS_HPP

#include "boost/format/format_class.hpp"
#include "boost/format/group.hpp"

#include "boost/throw_exception.hpp"

namespace boost {
namespace io {
namespace detail {
namespace  {

  inline
  void empty_buf(BOOST_IO_STD ostringstream & os) {
    static const std::string emptyStr;
    os.str(emptyStr);
  }

  void do_pad( std::string & s,
                std::streamsize w,
                const char c,
                std::ios::fmtflags f,
                bool center)
    // applies centered / left / right  padding  to the string s.
    // Effects : string s is padded.
  {
    std::streamsize n=w-s.size();
    if(n<=0) {
      return;
    }
    if(center)
      {
        s.reserve(w); // allocate once for the 2 inserts
        const std::streamsize n1 = n /2, n0 = n - n1;
        s.insert(s.begin(), n0, c);
        s.append(n1, c);
      }
    else
      {
        if(f & std::ios::left) {
          s.append(n, c);
        }
        else {
          s.insert(s.begin(), n, c);
        }
      }
  } // -do_pad(..)

  template<class T> inline
  void put_head(BOOST_IO_STD ostream& , const T& ) {
  }

  template<class T> inline
  void put_head( BOOST_IO_STD ostream& os, const group1<T>& x ) {
    os << group_head(x.a1_); // send the first N-1 items, not the last
  }

  template<class T> inline
  void put_last( BOOST_IO_STD ostream& os, const T& x ) {
    os << x ;
  }

  template<class T> inline
  void put_last( BOOST_IO_STD ostream& os, const group1<T>& x ) {
    os << group_last(x.a1_); // this selects the last element
  }

#ifndef BOOST_NO_OVERLOAD_FOR_NON_CONST
  template<class T> inline
  void put_head( BOOST_IO_STD ostream& , T& ) {
  }

  template<class T> inline
  void put_last( BOOST_IO_STD ostream& os, T& x ) {
    os << x ;
  }
#endif

template<class T>
void put( T x,
          const format_item& specs,
          std::string & res,
          BOOST_IO_STD ostringstream& oss_ )
{
  // does the actual conversion of x, with given params, into a string
  // using the *supplied* strinstream. (the stream state is important)

  typedef std::string string_t;
  typedef format_item  format_item_t;

  stream_format_state   prev_state(oss_);

  specs.state_.apply_on(oss_);

  // in case x is a group, apply the manip part of it,
  // in order to find width
  put_head( oss_, x );
  empty_buf( oss_);

  const std::streamsize w=oss_.width();
  const std::ios::fmtflags fl=oss_.flags();
  const bool internal = (fl & std::ios::internal) != 0;
  const bool two_stepped_padding = internal
    &&  ! ( specs.pad_scheme_ & format_item_t::spacepad )
    && specs.truncate_ < 0 ;

  if(! two_stepped_padding)
    {
      if(w>0) // handle simple padding via do_pad, not natively in stream
        oss_.width(0);
      put_last( oss_, x);
      res = oss_.str();

      if (specs.truncate_ >= 0)
        res.erase(specs.truncate_);

      // complex pads :
      if(specs.pad_scheme_ & format_item_t::spacepad)
        {
          if( res.size()==0 ||   ( res[0]!='+' && res[0]!='-'  ))
            {
              res.insert(res.begin(), 1, ' '); // insert 1 space at  pos 0
            }
        }
      if(w > 0) // need do_pad
        {
          do_pad(res,w,oss_.fill(), fl, (specs.pad_scheme_ & format_item_t::centered) !=0 );
        }
    }
  else  // 2-stepped padding
    {
      put_last( oss_, x); // oss_.width() may result in padding.
      res = oss_.str();

      if (specs.truncate_ >= 0)
        res.erase(specs.truncate_);

      if( res.size() - w > 0)
        { //   length w exceeded
          // either it was multi-output with first output padding up all width..
          // either it was one big arg and we are fine.
          empty_buf( oss_);
          oss_.width(0);
          put_last(oss_, x );
          string_t tmp = oss_.str();  // minimal-length output
          std::streamsize d;
          if( (d=w - tmp.size()) <=0 )
            {
              // minimal length is already >= w, so no padding  (cool!)
              res.swap(tmp);
            }
          else
            { // hum..  we need to pad (it was necessarily multi-output)
              typedef typename string_t::size_type size_type;
              size_type i = 0;
              while( i<tmp.size() && tmp[i] == res[i] ) // find where we should pad.
                ++i;
              tmp.insert(i, static_cast<size_type>( d ), oss_.fill());
              res.swap( tmp );
            }
        }
      else
        { // okay, only one thing was printed and padded, so res is fine.
        }
    }

  prev_state.apply_on(oss_);
  empty_buf( oss_);
  oss_.clear();
} // end- put(..)

}  // local namespace

template<class T>
void distribute(basic_format& self, T x)
  // call put(x, ..) on every occurence of the current argument :
{
  if(self.cur_arg_ >= self.num_args_)
    {
      if( self.exceptions() & too_many_args_bit )
        boost::throw_exception(too_many_args()); // too many variables have been supplied !
      else return;
    }
  for(unsigned long i=0; i < self.items_.size(); ++i)
    {
      if(self.items_[i].argN_ == self.cur_arg_)
        {
          put<T> (x, self.items_[i], self.items_[i].res_, self.oss_ );
        }
    }
}

template<class T>
basic_format&  feed(basic_format& self, T x)
{
  if(self.dumped_) self.clear();
  distribute<T> (self, x);
  ++self.cur_arg_;
  if(self.bound_.size() != 0)
    {
      while( self.cur_arg_ < self.num_args_ && self.bound_[self.cur_arg_] )
        ++self.cur_arg_;
    }

  // this arg is finished, reset the stream's format state
  self.state0_.apply_on(self.oss_);
  return self;
}

} // namespace detail
} // namespace io
} // namespace boost

#endif //  BOOST_FORMAT_FEED_ARGS_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// format_class.hpp :  class interface
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_CLASS_HPP
#define BOOST_FORMAT_CLASS_HPP

#include <vector>
#include <string>

#include <boost/format/format_fwd.hpp>
#include <boost/format/internals_fwd.hpp>

#include <boost/format/internals.hpp>

namespace boost {

class basic_format
{
public:
  typedef std::string                string_t;
  typedef BOOST_IO_STD ostringstream internal_stream_t;
private:
  typedef BOOST_IO_STD ostream       stream_t;
  typedef io::detail::stream_format_state  stream_format_state;
  typedef io::detail::format_item          format_item_t;

public:
  basic_format(const char* str);
  basic_format(const string_t& s);
#ifndef BOOST_NO_STD_LOCALE
  basic_format(const char* str, const std::locale & loc);
  basic_format(const string_t& s, const std::locale & loc);
#endif // no locale
  basic_format(const basic_format& x);
  basic_format& operator= (const basic_format& x);

  basic_format& clear(); // empty the string buffers (except bound arguments, see clear_binds() )

  // pass arguments through those operators :
  template<class T>  basic_format&   operator%(const T& x)
  {
    return io::detail::feed<const T&>(*this,x);
  }

#ifndef BOOST_NO_OVERLOAD_FOR_NON_CONST
  template<class T>  basic_format&   operator%(T& x)
  {
    return io::detail::feed<T&>(*this,x);
  }
#endif

  // system for binding arguments :
  template<class T>
  basic_format&         bind_arg(int argN, const T& val)
  {
    return io::detail::bind_arg_body(*this, argN, val);
  }
  basic_format&         clear_bind(int argN);
  basic_format&         clear_binds();

  // modify the params of a directive, by applying a manipulator :
  template<class T>
  basic_format&  modify_item(int itemN, const T& manipulator)
  {
    return io::detail::modify_item_body(*this, itemN, manipulator) ;
  }

  // Choosing which errors will throw exceptions :
  unsigned char exceptions() const;
  unsigned char exceptions(unsigned char newexcept);

  // final output
  string_t str() const;
  friend BOOST_IO_STD ostream&
  operator<< ( BOOST_IO_STD ostream& , const basic_format& );

  template<class T>  friend basic_format&
  io::detail::feed(basic_format&, T);

  template<class T>  friend
  void io::detail::distribute(basic_format&, T);

  template<class T>  friend
  basic_format&  io::detail::modify_item_body(basic_format&, int, const T&);

  template<class T> friend
  basic_format&  io::detail::bind_arg_body(basic_format&, int, const T&);

// make the members private only if the friend templates are supported
private:

  // flag bits, used for style_
  enum style_values  { ordered = 1,        // set only if all directives are  positional directives
                       special_needs = 4 };

  // parse the format string :
  void parse(const string_t&);

  int                           style_;         // style of format-string :  positional or not, etc
  int                           cur_arg_;       // keep track of wich argument will come
  int                           num_args_;      // number of expected arguments
  mutable bool                  dumped_;        // true only after call to str() or <<
  std::vector<format_item_t>    items_;         // vector of directives (aka items)
  string_t                      prefix_;        // piece of string to insert before first item

  std::vector<bool>             bound_;         // stores which arguments were bound
                                                //   size = num_args OR zero
  internal_stream_t             oss_;           // the internal stream.
  stream_format_state           state0_;        // reference state for oss_
  unsigned char                 exceptions_;
}; // class basic_format

} // namespace boost

#endif // BOOST_FORMAT_CLASS_HPP


code:
// -*- C++ -*-
//  Boost general library 'format'   ---------------------------
//  See http://www.boost.org for updates, documentation, and revision history.

//  (C) Samuel Krempp 2001
//                  krempp@crans.ens-cachan.fr
//  Permission to copy, use, modify, sell and
//  distribute this software is granted provided this copyright notice appears
//  in all copies. This software is provided "as is" without express or implied
//  warranty, and with no claim as to its suitability for any purpose.

// ideas taken from R�diger Loos's format class
// and Karl Nelson's ofstream (also took its parsing code as basis for printf parsing)

// ------------------------------------------------------------------------------
// format_fwd.hpp :  forward declarations, for primary header format.hpp
// ------------------------------------------------------------------------------

#ifndef BOOST_FORMAT_FWD_HPP
#define BOOST_FORMAT_FWD_HPP

#include <string>
#include <iosfwd>

namespace boost {

class basic_format;

typedef basic_format    format;

namespace io {
enum format_error_bits { bad_format_string_bit = 1,
                         too_few_args_bit = 2, too_many_args_bit = 4,
                         out_of_range_bit = 8,
                         all_error_bits = 255, no_error_bits=0 };

// Convertion:  format   to   string
std::string     str(const basic_format& ) ;

} // namespace io

BOOST_IO_STD ostream&
operator<<( BOOST_IO_STD ostream&, const basic_format&);

} // namespace boost

#endif // BOOST_FORMAT_FWD_HPP