code:
-*- mode: org -*-

[[https://www.gnu.org/software/guix/][GNU Guix]] (IPA: /ɡiːks/) is a purely functional package manager, and
associated free software distribution, for the [[https://www.gnu.org/gnu/gnu.html][GNU system]].  In addition
to standard package management features, Guix supports transactional
upgrades and roll-backs, unprivileged package management, per-user
profiles, and garbage collection.

It provides [[https://www.gnu.org/software/guile/][Guile]] Scheme APIs, including a high-level embedded
domain-specific languages (EDSLs) to describe how packages are to be
built and composed.

GNU Guix can be used on top of an already-installed GNU/Linux distribution, or
it can be used standalone (we call that “Guix System”).

Guix is based on the [[https://nixos.org/nix/][Nix]] package manager.

* Requirements

If you are building Guix from source, please see the manual for build
instructions and requirements, either by running:

  info -f doc/guix.info "Requirements"

or by checking the [[https://guix.gnu.org/manual/en/html_node/Requirements.html][web copy of the manual]].

* Installation

See the manual for the installation instructions, either by running

  info -f doc/guix.info "Installation"

or by checking the [[https://guix.gnu.org/manual/en/html_node/Installation.html][web copy of the manual]].

For information on installation from a Git checkout, please see the section
"Building from Git" in the manual.

* Installing Guix from Guix

You can re-build and re-install Guix using a system that already runs Guix.
To do so:

  - Start a shell with the development environment for Guix:

      guix environment guix

  - Re-run the 'configure' script passing it the option
    '--localstatedir=/somewhere', where '/somewhere' is the 'localstatedir'
    value of the currently installed Guix (failing to do that would lead the
    new Guix to consider the store to be empty!).  We recommend to use the
    value '/var'.

  - Run "make", "make check", and "make install".

* How It Works

Guix does the high-level preparation of a /derivation/.  A derivation is
the promise of a build; it is stored as a text file under
=/gnu/store/xxx.drv=.  The (guix derivations) module provides the
`derivation' primitive, as well as higher-level wrappers such as
`build-expression->derivation'.

Guix does remote procedure calls (RPCs) to the build daemon (the =guix-daemon=
command), which in turn performs builds and accesses to the store on its
behalf.  The RPCs are implemented in the (guix store) module.

* Contact

GNU Guix is hosted at https://savannah.gnu.org/projects/guix/.

Please email <help-guix@gnu.org> for questions and <bug-guix@gnu.org> for bug
reports; email <gnu-system-discuss@gnu.org> for general issues regarding the
GNU system.

Join #guix on irc.freenode.net.

* Guix & Nix

GNU Guix is based on [[https://nixos.org/nix/][the Nix package manager]].  It implements the same
package deployment paradigm, and in fact it reuses some of its code.
Yet, different engineering decisions were made for Guix, as described
below.

Nix is really two things: a package build tool, implemented by a library
and daemon, and a special-purpose programming language.  GNU Guix relies
on the former, but uses Scheme as a replacement for the latter.

Using Scheme instead of a specific language allows us to get all the
features and tooling that come with Guile (compiler, debugger, REPL,
Unicode, libraries, etc.)  And it means that we have a general-purpose
language, on top of which we can have embedded domain-specific languages
(EDSLs), such as the one used to define packages.  This broadens what
can be done in package recipes themselves, and what can be done around them.

Technically, Guix makes remote procedure calls to the ‘nix-worker’
daemon to perform operations on the store.  At the lowest level, Nix
“derivations” represent promises of a build, stored in ‘.drv’ files in
the store.  Guix produces such derivations, which are then interpreted
by the daemon to perform the build.  Thus, Guix derivations can use
derivations produced by Nix (and vice versa).

With Nix and the [[https://nixos.org/nixpkgs][Nixpkgs]] distribution, package composition happens at
the Nix language level, but builders are usually written in Bash.
Conversely, Guix encourages the use of Scheme for both package
composition and builders.  Likewise, the core functionality of Nix is
written in C++ and Perl; Guix relies on some of the original C++ code,
but exposes all the API as Scheme.

* Related software

  - [[https://nixos.org][Nix, Nixpkgs, and NixOS]], functional package manager and associated
    software distribution, are the inspiration of Guix
  - [[https://www.gnu.org/software/stow/][GNU Stow]] builds around the idea of one directory per prefix, and a
    symlink tree to create user environments
  - [[https://www.pvv.ntnu.no/~arnej/store/storedoc_6.html][STORE]] shares the same idea
  - [[https://live.gnome.org/OSTree/][GNOME's OSTree]] allows bootable system images to be built from a
    specified set of packages
  - The [[https://www.gnu.org/s/gsrc/][GNU Source Release Collection]] (GSRC) is a user-land software
    distribution; unlike Guix, it relies on core tools available on the
    host system

path: README


code:
-*- mode: org; coding: utf-8; -*-

#+TITLE: Tentative GNU Guix Road Map

Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>

  Copying and distribution of this file, with or without modification,
  are permitted in any medium without royalty provided the copyright
  notice and this notice are preserved.

The goals of the GNU Guix project are two-fold:

  - to build a purely functional package manager, based on Nix and
    Guile;

  - to use it to build a practical 100% free software distribution of
    GNU/Linux and possibly other GNU variants, with a focus on the
    promotion and tight integration of GNU components–the GNU system.

Since its inception, the project has gone a long way towards that goal.  Below
is a list of items we want for version "1.0" of the Guix System Distribution.
There will be a few 0.x releases by then to give the new features more
exposure and testing.

You're welcome to discuss this road map on guix-devel@gnu.org or #guix on
Freenode!

* Features scheduled for 1.0

  - larger & more robust build farm
    + we need a powerful, dedicated front-end
    + armhf-linux build machine
    + leave Hydra in favor of 'guix publish' + custom code?
  - more OS features
    + LVM support
    + encrypted root
    + configurable name service switch
    + whole-system unit tests, using VMs
  - more service definitions
    + mcron, postfix(?), wicd(?), etc.
  - better 'guix system'
    + 'reconfigure' should be able to restart non-essential services
    + support for '--list-generations' and '--delete-generations'
  - better 'guix pull'
    + using Git to fetch the source instead of re-downloading everything
    + build more quickly
    + install new .mo files and new manual
    + authentication of the Guix source: use signed commits?
  - simplified, purely declarative service list in 'operating-system'
    + it should be possible to inspect the service instance declarations and
      settings
  - GUIs
    + integrate guix-web?
    + guile-ncurses installer?
  - 'guix publish'?

* Features for later

  - complete GNU/Hurd port
  - use content-based addressing when downloading substitutes to reduce
    bandwidth requirements
    + design nar v2 format where file contents are replaced by their hashes
    + leverage /gnu/store/.links
  - binary origin tracking
    + keep signatures in sqlite.db
    + preserve signatures upon import/export
  - peer-to-peer distribution of updates (GNUnet?)
  - more deterministic builds
    + identify & fix sources of non-determinism in builds
    + strengthen guix-daemon containers to further increase reproducibility
    + trusting-trust: bootstrap with different tool chains
    + fixed-point: re-bootstrap until fixed point is reached
    + distributed validation: compare contents of store items with others
      * resist a hydra.gnu.org compromise
  - reproducible containers: mix of 'guix environment' and 'guix system vm'
  - execute code with least privilege
    + build containers like guix-daemon does
    + provide a Plash-like interface in Bash
  - daemon rewritten in Guile
  - more shepherd integration
    + monitor network interfaces and start/stop events based on that
    + include a DHCP client written in Scheme

path: ROADMAP

license: mit


code:
A big thanks to Eelco Dolstra, who designed and implemented Nix.
Transposing functional programming discipline to package management
proved to be inspiring and fruitful.

Thanks to the following people who contributed to GNU Guix through
suggestions, bug reports, patches, internationalization, or general
infrastructure help:

	    Lluís Batlle i Rossell <viric@viric.name>
          Sylvain Beucler <beuc@beuc.net>
	   Carlos Carleos <carleos@uniovi.es>
	   Felipe Castro <fefcas@gmail.com>
	   Daniel Clark <dclark@pobox.com>
	Alexandru Cojocaru <xojoc@gmx.com>
	    Aleix Conchillo Flaqué <aconchillo@gmail.com>
          Malcolm Cook <MEC@stowers.org>
           Thomas Danckaert <thomas.danckaert@gmail.com>
	   Rafael Ferreira <rafael.f.f1@gmail.com>
	Christian Grothoff <christian@grothoff.org>
             Eric Hanchrow <eric.hanchrow@gmail.com>
           Konrad Hinsen <konrad.hinsen@fastmail.net>
          Brandon Invergo <brandon@gnu.org>
           Anders Jonsson <anders.jonsson@norsjovallen.se>
	  Jeffrin Jose <ahiliation@yahoo.co.in>
	          Kete <kete@ninthfloor.org>
           Daniel Kochmański <dkochmanski@hellsgate.pl>
	  Matthew Lien <bluet@bluet.org>
             Dave Love <fx@gnu.org>
            Chris Marusich <cmmarusich@gmail.com>
            Niels Möller <nisse@lysator.liu.se>
          Cyprien Nicolas <cyprien@nicolas.tf>
	   Yutaka Niibe <gniibe@fsij.org>
           Andrei Osipov <andrspv@gmail.com>
                  Petter <petter@mykolab.ch>
             Adam Pribyl <pribyl@lowlevel.cz>
            Pjotr Prins <pjotr.public12@thebird.nl>
  Yakkala Yagnesh Raghava <hi@yagnesh.org>
           Joshua Randall <jcrandall@alum.mit.edu>
      Bruno Félix Rezende Ribeiro <oitofelix@gnu.org>
	    Benno Schulenberg <coordinator@translationproject.org>
           Thomas Schwinge <thomas@codesourcery.com>
        Alexander Shendi <Alexander.Shendi@web.de>
	     Alen Skondro <askondro@gmail.com>
              Jan Synáček <jan.synacek@gmail.com>
	 Matthias Wachs <wachs@net.in.tum.de>
Christopher Allan Webber <cwebber@dustycloud.org>
           Philip Woods <elzairthesorcerer@gmail.com>

GNU Guix also includes non-software works.  Thanks to the following
people who contributed the logo and general artwork and themes:

           Nikita Karetnikov <nikita@karetnikov.org>
           Felipe López <felipe.lopez@openmailbox.org>

path: THANKS


code:
-*- mode: org; coding: utf-8; -*-

#+TITLE: What's left to do?
#+STARTUP: content hidestars

Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com>

  Copying and distribution of this file, with or without modification,
  are permitted in any medium without royalty provided the copyright
  notice and this notice are preserved.

* MAYBE Add a substituter that uses the GNUnet DHT or [[http://libswift.org][libswift]]

Would be neat if binaries could be pushed to and pulled from the GNUnet DHT or
rather libswift (since DHTs aren’t suited for large payloads).  Guix users
would sign their binaries, and define which binaries they trust.

Use UPnP and similar to traverse NAT, like ‘filegive’ does.

* user interface
** add guile-ncurses interface

* extend <package>
** add ‘recommends’ field

For instance, glibc, binutils, gcc, and ld-wrapper would recommend each other.
‘guix package -i’ could ask interactively (?), or allow users to follow all or
none of the recommendations.

** add a ‘user-environment-hook’

This should specify builder code to be run when building a user
environment with ‘guix-package’.  For instance, Texinfo’s hook would
create a new ‘dir’.

** extend ‘propagated-build-inputs’ with support for multiple outputs

#+BEGIN_SRC scheme
  (outputs '("out" "include"))
  (propagated-build-inputs
    `(((("i1" ,p1 "o1")
        ("i2" ,p2))
       => "include")
      ("i3" ,p3)))
#+END_SRC

* synchronize non-GNU package descriptions with the [[http://directory.fsf.org][FSD]]

Meta-data for GNU packages, including descriptions and synopses, can be
dumped from the FSD:
http://directory.fsf.org/wiki?title=GNU/Export&action=purge .
We could periodically synchronize with that.

* add a guildhall build system

The Guildhall is Guile’s packaging system.  It should be easy to add a
‘guildhall-build-system’ that does the right thing based on guildhall
recipes.

* union

Support sophisticated collision handling when building a union: honor
per-package priorities, etc.

* add GUIX_ALLOW_EXPENSIVE_TESTS

Tests that need to download stuff or otherwise take a long time would only be
run when that is defined.

* guix build utils
** MAYBE Change ‘ld-wrapper’ to add RPATH for libs passed by file name

** MAYBE Add equivalent to chrpath that uses [[https://gitorious.org/guile-dlhacks/guile-dlhacks/][guile-dlhacks]]

** MAYBE Add a hash-rewriting thing for deep dependency replacement without rebuild

See [[https://github.com/NixOS/nixpkgs/commit/d1662d715514e6ef9d3dc29f132f1b3d8e608a18][Shea Levy's `replace-dependency' in Nixpkgs]].

* distro
** port to GNU/Hurd, aka. ‘i686-gnu’

Problems include that current glibc releases do not build on GNU/Hurd.
In addition, there haven’t been stable releases of GNU Mach, MiG, and
Hurd, which would be a pre-condition.

* Installer
** Fix impossibility to restart on error after cow-store has been started
See https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
- Force reboot upon installer failure
- Unshare the installer process
- Run the installer process in a separate namespace
** Partitioning
*** Add RAID support
*** Add more partitioning schemes
The actual schemes are taken from Debian Installer but some are not
implemented yet: like "Separate partitions for /home /var and /tmp".
*** Replace wait page "Partition formating is in progress, please wait"
Create a new waiting page describing what's being done:

[              20%              ]
Running mkfs.ext4 on /dev/sda2 ...

[              40%              ]
Running mkfs.ext4 on /dev/sda3 ...
*** Add a confirmation page before formating/partitioning
** Desktop environments
*** Allow for no desktop environments
Propose to choose between "headless server" and "lightweight X11" in a new
page.
*** Add services selection feature
Add a services page to the configuration. Ask for services to be installed
like SSH, bluetooth, TLP in a checkbox list?
** Locale and keymap
*** Try to guess user locale and keymap by probing BIOS or HW (dmidecode)
** Timezone
*** Regroup everything in one single page
Under the form:
(UTC + 1) Europe/Paris
(UTC + 2) Africa/Cairo
...
** Display issue
*** Investigate display issue described here:
https://lists.gnu.org/archive/html/guix-devel/2019-01/msg00305.html

path: TODO


code:
#!/bin/sh
# Create the build system.

set -e -x

# Generate stubs for translations.
langs=`find po/doc -type f -name 'guix-manual*.po' \
        | sed -e 's,guix-manual\.,,' \
        | xargs -n 1 -I{} basename {} .po`
for lang in ${langs}; do
    if [ ! -e "doc/guix.${lang}.texi" ]; then
	echo "@setfilename guix.${lang}.info" > "doc/guix.${lang}.texi"
	echo "@include version-${lang}.texi" >> "doc/guix.${lang}.texi"
	# Ensure .po file is newer.
	touch "po/doc/guix-manual.${lang}.po"
    fi
done
langs=`find po/doc -type f -name 'guix-cookbook*.po' \
        | sed -e 's,guix-cookbook\.,,' \
        | xargs -n 1 -I{} basename {} .po`
for lang in ${langs}; do
    if [ ! -e "doc/guix-cookbook.${lang}.texi" ]; then
	echo "@setfilename guix-cookbook.${lang}.info" > "doc/guix-cookbook.${lang}.texi"
	# Ensure .po file is newer.
	touch "po/doc/guix-cookbook.${lang}.po"
    fi
done

exec autoreconf -vfi

path: bootstrap


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

(define-module (build-self)
  #:use-module (gnu)
  #:use-module (guix)
  #:use-module (guix ui)
  #:use-module (guix config)
  #:use-module (guix modules)
  #:use-module (guix build-system gnu)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:export (build))

;;; Commentary:
;;;
;;; When loaded, this module returns a monadic procedure of at least one
;;; argument: the source tree to build.  It returns a derivation that
;;; builds it.
;;;
;;; This file uses modules provided by the already-installed Guix.  Those
;;; modules may be arbitrarily old compared to the version we want to
;;; build.  Because of that, it must rely on the smallest set of features
;;; that are likely to be provided by the (guix) and (gnu) modules, and by
;;; Guile itself, forever and ever.
;;;
;;; Code:

;;;
;;; Generating (guix config).
;;;
;;; This is copied from (guix self) because we cannot assume (guix self) is
;;; available at this point.
;;;

(define %persona-variables
  ;; (guix config) variables that define Guix's persona.
  '(%guix-package-name
    %guix-version
    %guix-bug-report-address
    %guix-home-page-url))

(define %config-variables
  ;; (guix config) variables corresponding to Guix configuration.
  (letrec-syntax ((variables (syntax-rules ()
                               ((_)
                                '())
                               ((_ variable rest ...)
                                (cons `(variable . ,variable)
                                      (variables rest ...))))))
    (variables %localstatedir %storedir %sysconfdir %system)))

(define* (make-config.scm #:key gzip xz bzip2
                          (package-name "GNU Guix")
                          (package-version "0")
                          (bug-report-address "bug-guix@gnu.org")
                          (home-page-url "https://guix.gnu.org"))

  ;; Hack so that Geiser is not confused.
  (define defmod 'define-module)

  (scheme-file "config.scm"
               #~(begin
                   (#$defmod (guix config)
                     #:export (%guix-package-name
                               %guix-version
                               %guix-bug-report-address
                               %guix-home-page-url
                               %store-directory
                               %state-directory
                               %store-database-directory
                               %config-directory
                               %libz
                               %gzip
                               %bzip2
                               %xz))

                   ;; XXX: Work around <http://bugs.gnu.org/15602>.
                   (eval-when (expand load eval)
                     #$@(map (match-lambda
                               ((name . value)
                                #~(define-public #$name #$value)))
                             %config-variables)

                     (define %store-directory
                       (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
                           %storedir))

                     (define %state-directory
                       ;; This must match `NIX_STATE_DIR' as defined in
                       ;; `nix/local.mk'.
                       (or (getenv "GUIX_STATE_DIRECTORY")
                           (string-append %localstatedir "/guix")))

                     (define %store-database-directory
                       (or (getenv "GUIX_DATABASE_DIRECTORY")
                           (string-append %state-directory "/db")))

                     (define %config-directory
                       ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
                       ;; defined in `nix/local.mk'.
                       (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
                           (string-append %sysconfdir "/guix")))

                     (define %guix-package-name #$package-name)
                     (define %guix-version #$package-version)
                     (define %guix-bug-report-address #$bug-report-address)
                     (define %guix-home-page-url #$home-page-url)

                     (define %gzip
                       #+(and gzip (file-append gzip "/bin/gzip")))
                     (define %bzip2
                       #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
                     (define %xz
                       #+(and xz (file-append xz "/bin/xz")))))))

;;;
;;; 'gexp->script'.
;;;
;;; This is our own variant of 'gexp->script' with an extra #:module-path
;;; parameter, which was unavailable in (guix gexp) until commit
;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
;;;

(define (load-path-expression modules path)
  "Return as a monadic value a gexp that sets '%load-path' and
'%load-compiled-path' to point to MODULES, a list of module names.  MODULES
are searched for in PATH."
  (mlet %store-monad ((modules  (imported-modules modules
                                                  #:module-path path))
                      (compiled (compiled-modules modules
                                                  #:module-path path)))
    (return (gexp (eval-when (expand load eval)
                    (set! %load-path
                      (cons (ungexp modules) %load-path))
                    (set! %load-compiled-path
                      (cons (ungexp compiled)
                            %load-compiled-path)))))))

(define* (gexp->script name exp
                       #:key (guile (default-guile))
                       (module-path %load-path))
  "Return an executable script NAME that runs EXP using GUILE, with EXP's
imported modules in its search path."
  (mlet %store-monad ((set-load-path
                       (load-path-expression (gexp-modules exp)
                                             module-path)))
    (gexp->derivation name
                      (gexp
                       (call-with-output-file (ungexp output)
                         (lambda (port)
                           ;; Note: that makes a long shebang.  When the store
                           ;; is /gnu/store, that fits within the 128-byte
                           ;; limit imposed by Linux, but that may go beyond
                           ;; when running tests.
                           (format port
                                   "#!~a/bin/guile --no-auto-compile~%!#~%"
                                   (ungexp guile))

                           (write '(ungexp set-load-path) port)
                           (write '(ungexp exp) port)
                           (chmod port #o555))))
                      #:module-path module-path)))

(define (date-version-string)
  "Return the current date and hour in UTC timezone, for use as a poor
person's version identifier."
  ;; XXX: Replace with a Git commit id.
  (date->string (current-date 0) "~Y~m~d.~H"))

(define guile-gcrypt
  ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
  ;; August 2018.  If it has it, it's at least version 0.1.0, which is good
  ;; enough.  If it doesn't, specify our own package because the target Guix
  ;; requires it.
  (match (find-best-packages-by-name "guile-gcrypt" #f)
    (()
     (package
       (name "guile-gcrypt")
       (version "0.1.0")
       (home-page "https://notabug.org/cwebber/guile-gcrypt")
       (source (origin
                 (method url-fetch)
                 (uri (string-append home-page "/archive/v" version ".tar.gz"))
                 (sha256
                  (base32
                   "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
                 (file-name (string-append name "-" version ".tar.gz"))))
       (build-system gnu-build-system)
       (arguments
        ;; The 'bootstrap' phase appeared in 'core-updates', which was merged
        ;; into 'master' ca. June 2018.
        '(#:phases (modify-phases %standard-phases
                     (delete 'bootstrap)
                     (add-before 'configure 'bootstrap
                       (lambda _
                         (unless (zero? (system* "autoreconf" "-vfi"))
                           (error "autoreconf failed"))
                         #t)))))
       (native-inputs
        `(("pkg-config" ,(specification->package "pkg-config"))
          ("autoconf" ,(specification->package "autoconf"))
          ("automake" ,(specification->package "automake"))
          ("texinfo" ,(specification->package "texinfo"))))
       (inputs
        `(("guile" ,(specification->package "guile"))
          ("libgcrypt" ,(specification->package "libgcrypt"))))
       (synopsis "Cryptography library for Guile using Libgcrypt")
       (description
        "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
GNU Libgcrypt crytographic library.  It provides modules for cryptographic
hash functions, message authentication codes (MAC), public-key cryptography,
strong randomness, and more.  It is implemented using the foreign function
interface (FFI) of Guile.")
       (license #f)))                             ;license:gpl3+
    ((package . _)
     package)))

(define* (build-program source version
                        #:optional (guile-version (effective-version))
                        #:key (pull-version 0))
  "Return a program that computes the derivation to build Guix from SOURCE."
  (define select?
    ;; Select every module but (guix config) and non-Guix modules.
    (match-lambda
      (('guix 'config) #f)
      (('guix _ ...)   #t)
      (('gnu _ ...)    #t)
      (_               #f)))

  (define fake-gcrypt-hash
    ;; Fake (gcrypt hash) module; see below.
    (scheme-file "hash.scm"
                 #~(define-module (gcrypt hash)
                     #:export (sha1 sha256))))

  (define fake-git
    (scheme-file "git.scm" #~(define-module (git))))

  (with-imported-modules `(((guix config)
                            => ,(make-config.scm))

                           ;; To avoid relying on 'with-extensions', which was
                           ;; introduced in 0.15.0, provide a fake (gcrypt
                           ;; hash) just so that we can build modules, and
                           ;; adjust %LOAD-PATH later on.
                           ((gcrypt hash) => ,fake-gcrypt-hash)

                           ;; (guix git-download) depends on (git) but only
                           ;; for peripheral functionality.  Provide a dummy
                           ;; (git) to placate it.
                           ((git) => ,fake-git)

                           ,@(source-module-closure `((guix store)
                                                      (guix self)
                                                      (guix derivations)
                                                      (gnu packages bootstrap))
                                                    (list source)
                                                    #:select? select?))
    (gexp->script "compute-guix-derivation"
                  #~(begin
                      (use-modules (ice-9 match)
                                   (ice-9 threads))

                      (eval-when (expand load eval)
                        ;; (gnu packages …) modules are going to be looked up
                        ;; under SOURCE.  (guix config) is looked up in FRONT.
                        (match (command-line)
                          ((_ source _ ...)
                           (match %load-path
                             ((front _ ...)
                              (unless (string=? front source) ;already done?
                                (set! %load-path
                                  (list source
                                        (string-append #$guile-gcrypt
                                                       "/share/guile/site/"
                                                       (effective-version))
                                        front)))))))

                        ;; Only load Guile-Gcrypt, our own modules, or those
                        ;; of Guile.
                        (set! %load-compiled-path
                          (cons (string-append #$guile-gcrypt "/lib/guile/"
                                               (effective-version)
                                               "/site-ccache")
                                %load-compiled-path))

                        ;; Disable position recording to save time and space
                        ;; when loading the package modules.
                        (read-disable 'positions))

                      (use-modules (guix store)
                                   (guix self)
                                   (guix derivations)
                                   (srfi srfi-1))

                      (define (spin system)
                        (define spin
                          (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))

                        (format (current-error-port)
                                "Computing Guix derivation for '~a'...  "
                                system)
                        (when (isatty? (current-error-port))
                          (let loop ((spin spin))
                            (display (string-append "\b" (car spin))
                                     (current-error-port))
                            (force-output (current-error-port))
                            (sleep 1)
                            (loop (cdr spin)))))

                      (match (command-line)
                        ((_ source system version protocol-version)
                         ;; The current input port normally wraps a file
                         ;; descriptor connected to the daemon, or it is
                         ;; connected to /dev/null.  In the former case, reuse
                         ;; the connection such that we inherit build options
                         ;; such as substitute URLs and so on; in the latter
                         ;; case, attempt to open a new connection.
                         (let* ((proto (string->number protocol-version))
                                (store (if (integer? proto)
                                           (port->connection (duplicate-port
                                                              (current-input-port)
                                                              "w+0")
                                                             #:version proto)
                                           (open-connection))))
                           (call-with-new-thread
                            (lambda ()
                              (spin system)))

                           (display
                            (and=>
                             (run-with-store store
                               (guix-derivation source version
                                                #$guile-version
                                                #:pull-version
                                                #$pull-version)
                               #:system system)
                             derivation-file-name))))))
                  #:module-path (list source))))

(define (call-with-clean-environment thunk)
  (let ((env (environ)))
    (dynamic-wind
      (lambda ()
        (environ '()))
      thunk
      (lambda ()
        (environ env)))))

(define-syntax-rule (with-clean-environment exp ...)
  "Evaluate EXP in a context where zero environment variables are defined."
  (call-with-clean-environment (lambda () exp ...)))

;; The procedure below is our return value.
(define* (build source
                #:key verbose? (version (date-version-string)) system
                (pull-version 0)

                ;; For the standalone Guix, default to Guile 3.0.  For old
                ;; versions of 'guix pull' (pre-0.15.0), we have to use the
                ;; same Guile as the current one.
                (guile-version (if (> pull-version 0)
                                   "3.0"
                                   (effective-version)))

                #:allow-other-keys
                #:rest rest)
  "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
files."
  ;; Build the build program and then use it as a trampoline to build from
  ;; SOURCE.
  (mlet %store-monad ((build  (build-program source version guile-version
                                             #:pull-version pull-version))
                      (system (if system (return system) (current-system)))
                      (home -> (getenv "HOME"))

                      ;; Note: Use the deprecated names here because the
                      ;; caller might be Guix <= 0.16.0.
                      (port   ((store-lift nix-server-socket)))
                      (major  ((store-lift nix-server-major-version)))
                      (minor  ((store-lift nix-server-minor-version))))
    (mbegin %store-monad
      ;; Before 'with-build-handler' was implemented and used, we had to
      ;; explicitly call 'show-what-to-build*'.
      (munless (module-defined? (resolve-module '(guix store))
                                'with-build-handler)
        (show-what-to-build* (list build)))
      (built-derivations (list build))

      ;; Use the port beneath the current store as the stdin of BUILD.  This
      ;; way, we know 'open-pipe*' will not close it on 'exec'.  If PORT is
      ;; not a file port (e.g., it's an SSH channel), then the subprocess's
      ;; stdin will actually be /dev/null.
      (let* ((pipe   (with-input-from-port port
                       (lambda ()
                         ;; Make sure BUILD is not influenced by
                         ;; $GUILE_LOAD_PATH & co.
                         (with-clean-environment
                          (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
                          (setenv "COLUMNS" "120") ;show wider backtraces
                          (when home
                            ;; Inherit HOME so that 'xdg-directory' works.
                            (setenv "HOME" home))
                          (open-pipe* OPEN_READ
                                      (derivation->output-path build)
                                      source system version
                                      (if (file-port? port)
                                          (number->string
                                           (logior major minor))
                                          "none"))))))
             (str    (get-string-all pipe))
             (status (close-pipe pipe)))
        (match str
          ((? eof-object?)
           (error "build program failed" (list build status)))
          ((? derivation-path? drv)
           (mbegin %store-monad
             (return (newline (current-error-port)))
             ((store-lift add-temp-root) drv)
             (return (read-derivation-from-file drv))))
          ("#f"
           ;; Unsupported PULL-VERSION.
           (return #f))
          ((? string? str)
           (raise (condition
                   (&message
                    (message (format #f "You found a bug: the program '~a'
failed to compute the derivation for Guix (version: ~s; system: ~s;
host version: ~s; pull-version: ~s).
Please report it by email to <~a>.~%"
                                     (derivation->output-path build)
                                     version system %guix-version pull-version
                                     %guix-bug-report-address)))))))))))

;; This file is loaded by 'guix pull'; return it the build procedure.
build

;; Local Variables:
;; eval: (put 'with-load-path 'scheme-indent-function 1)
;; End:

;;; build-self.scm ends here


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

;;;
;;; Validate 'etc/news.scm'.
;;;

(use-modules (git)
             (guix git)
             (guix ui)
             (guix channels)
             (srfi srfi-26)
             (ice-9 match))

;; XXX: These two things are currently private.
(define read-channel-news (@@ (guix channels) read-channel-news))
(define channel-news-entries (cut struct-ref <> 0))

(define (all-the-news directory)
  "Return the <channel-news> read from DIRECTORY, a checkout of the 'guix'
channel."
  (call-with-input-file (string-append directory "/etc/news.scm")
    read-channel-news))

(define (validate-texinfo str type language)
  "Parse STR as a Texinfo fragment and raise an error if that fails."
  (catch #t
    (lambda ()
      (texi->plain-text str))
    (lambda (key . args)
      (print-exception (current-error-port) #f key args)
      (report-error (G_ "the Texinfo snippet below is invalid (~a, ~a):~%")
                    type language)
      (display str (current-error-port))
      (exit 1))))

(define (validate-news-entry repository entry)
  "Validate ENTRY, a <channel-news-entry>, making sure it refers to an
existent commit of REPOSITORY and contains only valid Texinfo."
  (catch 'git-error
    (lambda ()
      (let ((commit (commit-lookup repository
                                   (string->oid
                                    (channel-news-entry-commit entry)))))
        (for-each (match-lambda
                    ((language . title)
                     (validate-texinfo title 'title language)))
                  (channel-news-entry-title entry))
        (for-each (match-lambda
                    ((language . body)
                     (validate-texinfo body 'body language)))
                  (channel-news-entry-body entry))))
    (lambda (key error . rest)
      (if (= GIT_ENOTFOUND (git-error-code error))
          (leave (G_ "commit '~a' of entry '~a' does not exist~%")
                 (channel-news-entry-commit entry)
                 (channel-news-entry-title entry))
          (apply throw key error rest)))))

(let* ((this-directory (dirname (current-filename)))
       (top-directory  (string-append this-directory "/.."))
       (entries        (channel-news-entries (all-the-news top-directory))))
  (with-repository top-directory repository
    (for-each (cut validate-news-entry repository <>)
              entries)
    (info (G_ "All ~a channel news entries are valid.~%")
          (length entries))))


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

;;;
;;; Check whether important binaries are available.
;;;

(use-modules (guix store)
             (guix grafts)
             (guix packages)
             (guix derivations)
             (guix ui)
             (gnu packages commencement)
             (ice-9 match)
             (srfi srfi-1)
             (srfi srfi-26))

(define (final-inputs store system)
  "Return the list of outputs directories of the final inputs for SYSTEM."
  (append-map (match-lambda
                ((or (name package) (name package _))
                 (let ((drv (package-derivation store package system)))
                   ;; Libc's 'debug' output refers to gcc-cross-boot0, but it's
                   ;; hard to avoid, so we tolerate it.  This should be the
                   ;; only exception.  Likewise, 'bash:include' depends on
                   ;; bootstrap-binaries via its 'Makefile.inc' (FIXME).
                   (filter-map (match-lambda
                                 (("debug" . directory)
                                  (if (string=? "glibc" (package-name package))
                                      #f
                                      directory))
                                 (("include" . directory)
                                  (if (string=? "bash" (package-name package))
                                      #f
                                      directory))
                                 ((_ . directory) directory))
                               (derivation->output-paths drv)))))
              %final-inputs))

(define (assert-valid-substitute substitute)
  "Make sure SUBSTITUTE does not refer to any bootstrap inputs, and bail out
if it does."
  (let ((references (substitutable-references substitute)))
    (when (any (cut string-contains <> "boot") references)
      (leave (G_ "'~a' refers to bootstrap inputs: ~s~%")
             (substitutable-path substitute) references))))

(define (test-final-inputs store system)
  "Check whether the final inputs for SYSTEM are clean---i.e., they don't
refer to the bootstrap tools."
  (format #t "checking final inputs for '~a'...~%" system)
  (let* ((inputs    (final-inputs store system))
         (available (substitutable-path-info store inputs)))
    (for-each (lambda (dir)
                (unless (find (lambda (substitute)
                                (string=? (substitutable-path substitute)
                                          dir))
                              available)
                  (leave (G_ "~a (system: ~a) has no substitute~%")
                         dir system)))
              inputs)

    (for-each assert-valid-substitute available)))

;; Entry point.
(with-store store
  (parameterize ((%graft? #f))
    (set-build-options store #:use-substitutes? #t)

    (for-each (cut test-final-inputs store <>)
              %hydra-supported-systems)))


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

(use-modules (ice-9 format)
             (ice-9 match)
             (ice-9 threads)
             (srfi srfi-1)
             (guix build compile)
             (guix build utils))

(define host (getenv "host"))
(define srcdir (getenv "srcdir"))

(define (relative-file file)
  (if (string-prefix? (string-append srcdir "/") file)
      (string-drop file (+ 1 (string-length srcdir)))
      file))

(define (file-mtime<? f1 f2)
  (< (stat:mtime (stat f1))
     (stat:mtime (stat f2))))

(define (scm->go file)
  (let* ((relative (relative-file file))
         (without-extension (string-drop-right relative 4)))
    (string-append without-extension ".go")))

(define (file-needs-compilation? file)
  (let ((go (scm->go file)))
    (or (not (file-exists? go))
        (file-mtime<? go file))))

(define* (parallel-job-count #:optional (flags (getenv "MAKEFLAGS")))
  "Return the number of parallel jobs as determined by FLAGS, the flags passed
to 'make'."
  (match flags
    (#f (current-processor-count))
    (flags
     (let ((initial-flags (string-tokenize flags)))
       (let loop ((flags initial-flags))
         (match flags
           (()
            ;; Note: GNU make prior to version 4.2 would hide "-j" flags from
            ;; $MAKEFLAGS.  Thus, check for a "--jobserver" flag here and
            ;; assume we're using all cores if specified.
            (if (any (lambda (flag)
                       (string-prefix? "--jobserver" flag))
                     initial-flags)
                (current-processor-count)         ;GNU make < 4.2
                1))                               ;sequential make
           (("-j" (= string->number count) _ ...)
            (if (integer? count)
                count
                (current-processor-count)))
           ((head tail ...)
            (if (string-prefix? "-j" head)
                (match (string-drop head 2)
                  (""
                   (current-processor-count))
                  ((= string->number count)
                   (if (integer? count)
                       count
                       (current-processor-count))))
                (loop tail)))))))))

(define (parallel-job-count*)
  ;; XXX: Work around memory requirements not sustainable on i686 above '-j4'
  ;; or so: <https://bugs.gnu.org/40522>.
  (let ((count (parallel-job-count)))
    (if (string-prefix? "i686" %host-type)
        (min count 4)
        count)))

(define (% completed total)
  "Return the completion percentage of COMPLETED over TOTAL as an integer."
  (inexact->exact (round (* 100. (/ completed total)))))

;; Install a SIGINT handler to give unwind handlers in 'compile-file' an
;; opportunity to run upon SIGINT and to remove temporary output files.
(sigaction SIGINT
  (lambda args
    (exit 1)))

(match (command-line)
  ((_ . files)
   (catch #t
     (lambda ()
       (compile-files srcdir (getcwd)
                      (filter file-needs-compilation? files)
                      #:workers (parallel-job-count*)
                      #:host host
                      #:report-load (lambda (file total completed)
                                      (when file
                                        (format #t "[~3d%] LOAD     ~a~%"
                                                (% (+ 1 completed) (* 2 total))
                                                file)
                                        (force-output)))
                      #:report-compilation (lambda (file total completed)
                                             (when file
                                               (format #t "[~3d%] GUILEC   ~a~%"
                                                       (% (+ total completed 1)
                                                          (* 2 total))
                                                       (scm->go file))
                                               (force-output)))))
     (lambda _
       (primitive-exit 1))
     (lambda args
       ;; Try to report the error in an intelligible way.
       (let* ((stack   (make-stack #t))
              (frame   (if (> (stack-length stack) 1)
                           (stack-ref stack 1)    ;skip the 'throw' frame
                           (stack-ref stack 0)))
              (ui      (false-if-exception
                        (resolve-module '(guix ui))))
              (report  (and ui
                            (false-if-exception
                             (module-ref ui 'report-load-error)))))
         (if report
             ;; In Guile <= 2.2.5, 'current-load-port' was not exported.
             (let ((load-port ((module-ref (resolve-module '(ice-9 ports))
                                           'current-load-port))))
               (report (or (and=> load-port port-filename) "?.scm")
                       args frame))
             (begin
               (print-exception (current-error-port) frame
                                (car args) (cdr args))
               (display-backtrace stack (current-error-port)))))))))


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

;; Build Guix using Guix.

(use-modules (srfi srfi-26))

;; Add ~/.config/guix/current to the search path.
(eval-when (expand load eval)
  (and=> (or (getenv "XDG_CONFIG_HOME")
             (and=> (getenv "HOME")
                    (cut string-append <> "/.config/guix/current")))
         (lambda (current)
           (set! %load-path
             (cons (string-append current "/share/guile/site/"
                                  (effective-version))
                   %load-path))
           (set! %load-compiled-path
             (cons (string-append current "/lib/guile/" (effective-version)
                                  "/site-ccache")
                   %load-compiled-path)))))

(use-modules (guix) (guix ui)
             (guix git-download)
             (ice-9 match))

(match (command-line)
  ((program source)
   (with-error-handling
     (with-store store
       (let* ((script (string-append source "/build-aux/build-self.scm"))
              (build  (primitive-load script))
              (git?   (git-predicate source)))
         (run-with-store store
           ;; TODO: Extract #:version and #:commit using Guile-Git.
           (mlet* %store-monad ((source (interned-file source "guix-source"
                                                       #:select? git?
                                                       #:recursive? #t))
                                (drv    (build source #:pull-version 1)))
             (mbegin %store-monad
               (show-what-to-build* (list drv))
               (built-derivations (list drv))
               (with-monad %store-monad
                 (display (derivation->output-path drv))
                 (newline)
                 (return drv))))))))))


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

;;;
;;; This file defines build jobs for the Cuirass continuation integration
;;; tool.
;;;

(include "../hydra/gnu-system.scm")
(include "hydra-to-cuirass.scm")


code:
;;;
;;; This file defines Cuirass build jobs to build Guix itself.
;;;

(include "../hydra/guix-modular.scm")
(include "hydra-to-cuirass.scm")


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

;;;
;;; This file defines the conversion of Hydra build jobs to Cuirass build
;;; jobs.  It is meant to be included in other files.
;;;

(use-modules ((guix licenses)
              #:select (license? license-name license-uri license-comment)))

(define (cuirass-jobs store arguments)
  "Return Cuirass jobs."
  (map hydra-job->cuirass-job (hydra-jobs store arguments)))

(define (hydra-job->cuirass-job hydra-job)
  (let ((name (car hydra-job))
        (job ((cdr hydra-job))))
    (lambda _ (acons #:job-name (symbol->string name)
                     (map symbol-alist-entry->keyword-alist-entry job)))))

(define (symbol-alist-entry->keyword-alist-entry entry)
  (cons (symbol->keyword (car entry)) (entry->sexp-entry (cdr entry))))

(define (entry->sexp-entry o)
  (match o
    ((? license?) `((name . (license-name o))
                    (uri . ,(license-uri o))
                    (comment . ,(license-comment o))))
    ((lst ...)
     (map entry->sexp-entry lst))
    (_ o)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Alex Kost <alezost@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/>.

;;;
;;; Generate AUTHORS file for directory with the Guix git repository.
;;;

(use-modules
 (ice-9 popen)
 (ice-9 rdelim)
 (ice-9 match)
 (srfi srfi-1)
 (guix config)
 (guix utils)
 (guix build utils))

(define %guix-dir
  (make-parameter #f))

(define-syntax-rule (append-maybe init-lst (test add-lst) ...)
  (let* ((lst init-lst)
         (lst (if test
                  (append lst add-lst)
                  lst))
         ...)
    lst))

(define (command-output cmd . args)
  "Execute CMD with ARGS and return its output without trailing newspace."
  (let* ((port (apply open-pipe* OPEN_READ cmd args))
         (output (read-string port)))
    (close-port port)
    (string-trim-right output #\newline)))

(define (git-output . args)
  "Execute git command with ARGS and return its output without trailing
newspace."
  (with-directory-excursion (%guix-dir)
    (apply command-output "git" args)))

(define* (contributors-string #:optional (range "HEAD"))
  "Return a string with names of people contributed to commit RANGE."
  (git-output "shortlog" "--numbered" "--summary" "--email" range))

(define* (tags #:key pattern sort)
  "Return a list of the git repository tags.
PATTERN is passed to '--list' and SORT is passed to '--sort' options of
'git tag' command."
  (let* ((args (append-maybe
                '("tag")
                (pattern (list "--list" pattern))
                (sort    (list "--sort" sort))))
         (output (apply git-output args)))
    (string-split output #\newline)))

(define (version-tags)
  "Return only version tags (v0.8, etc.) sorted from the biggest version
to the smallest one."
  (tags #:pattern "v*"
        #:sort "-version:refname"))

(define (generate-authors-file file)
  "Generate authors FILE."
  (define previous-release-tag
    (find (lambda (tag)
            (version>? %guix-version
                       (substring tag 1))) ; remove leading 'v'
          (version-tags)))

  (define release-range
    (string-append previous-release-tag "..HEAD"))

  (with-output-to-file file
    (lambda ()
      (display "\
GNU Guix consists of Scheme code that implements the deployment model
of the Nix package management tool.  In fact, it currently talks to a
build daemon whose code comes from Nix (see the manual for details.)

Nix was initially written by Eelco Dolstra; other people have been
contributing to it.  See `nix/AUTHORS' for details.\n\n")
      (format #t "Contributors to GNU Guix ~a:\n\n"
              %guix-version)
      (display (contributors-string release-range))
      (newline) (newline)
      (display "Overall contributors:\n\n")
      (display (contributors-string))
      (newline))))

(define (show-help)
  (match (command-line)
    ((me _ ...)
     (format #t "Usage: guile ~a DIRECTORY AUTHORS
Generate AUTHORS file for DIRECTORY with the Guix git repository.\n"
             me))))

(match (command-line)
  ((_ guix-dir authors-file)
   (parameterize ((%guix-dir guix-dir))
     (generate-authors-file authors-file)))
  (_
   (show-help)
   (exit 1)))

;;; generate-authors.scm ends here


code:
#!/bin/sh
# Print a version string.
scriptversion=2017-01-09.19; # UTC

# Copyright (C) 2007-2017 Free Software Foundation, Inc.
#
# This program 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.
#
# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

# This script is derived from GIT-VERSION-GEN from GIT: http://git.or.cz/.
# It may be run two ways:
# - from a git repository in which the "git describe" command below
#   produces useful output (thus requiring at least one signed tag)
# - from a non-git-repo directory containing a .tarball-version file, which
#   presumes this script is invoked like "./git-version-gen .tarball-version".

# In order to use intra-version strings in your project, you will need two
# separate generated version string files:
#
# .tarball-version - present only in a distribution tarball, and not in
#   a checked-out repository.  Created with contents that were learned at
#   the last time autoconf was run, and used by git-version-gen.  Must not
#   be present in either $(srcdir) or $(builddir) for git-version-gen to
#   give accurate answers during normal development with a checked out tree,
#   but must be present in a tarball when there is no version control system.
#   Therefore, it cannot be used in any dependencies.  GNUmakefile has
#   hooks to force a reconfigure at distribution time to get the value
#   correct, without penalizing normal development with extra reconfigures.
#
# .version - present in a checked-out repository and in a distribution
#   tarball.  Usable in dependencies, particularly for files that don't
#   want to depend on config.h but do want to track version changes.
#   Delete this file prior to any autoconf run where you want to rebuild
#   files to pick up a version string change; and leave it stale to
#   minimize rebuild time after unrelated changes to configure sources.
#
# As with any generated file in a VC'd directory, you should add
# /.version to .gitignore, so that you don't accidentally commit it.
# .tarball-version is never generated in a VC'd directory, so needn't
# be listed there.
#
# Use the following line in your configure.ac, so that $(VERSION) will
# automatically be up-to-date each time configure is run (and note that
# since configure.ac no longer includes a version string, Makefile rules
# should not depend on configure.ac for version updates).
#
# AC_INIT([GNU project],
#         m4_esyscmd([build-aux/git-version-gen .tarball-version]),
#         [bug-project@example])
#
# Then use the following lines in your Makefile.am, so that .version
# will be present for dependencies, and so that .version and
# .tarball-version will exist in distribution tarballs.
#
# EXTRA_DIST = $(top_srcdir)/.version
# BUILT_SOURCES = $(top_srcdir)/.version
# $(top_srcdir)/.version:
#	echo $(VERSION) > $@-t && mv $@-t $@
# dist-hook:
#	echo $(VERSION) > $(distdir)/.tarball-version

me=$0

version="git-version-gen $scriptversion

Copyright 2011 Free Software Foundation, Inc.
There is NO warranty.  You may redistribute this software
under the terms of the GNU General Public License.
For more information about these matters, see the files named COPYING."

usage="\
Usage: $me [OPTION]... \$srcdir/.tarball-version [TAG-NORMALIZATION-SED-SCRIPT]
Print a version string.

Options:

   --prefix PREFIX    prefix of git tags (default 'v')
   --fallback VERSION
                      fallback version to use if \"git --version\" fails

   --help             display this help and exit
   --version          output version information and exit

Running without arguments will suffice in most cases."

prefix=v
fallback=

while test $# -gt 0; do
  case $1 in
    --help) echo "$usage"; exit 0;;
    --version) echo "$version"; exit 0;;
    --prefix) shift; prefix=${1?};;
    --fallback) shift; fallback=${1?};;
    -*)
      echo "$0: Unknown option '$1'." >&2
      echo "$0: Try '--help' for more information." >&2
      exit 1;;
    *)
      if test "x$tarball_version_file" = x; then
        tarball_version_file="$1"
      elif test "x$tag_sed_script" = x; then
        tag_sed_script="$1"
      else
        echo "$0: extra non-option argument '$1'." >&2
        exit 1
      fi;;
  esac
  shift
done

if test "x$tarball_version_file" = x; then
    echo "$usage"
    exit 1
fi

tag_sed_script="${tag_sed_script:-s/x/x/}"

nl='
'

# Avoid meddling by environment variable of the same name.
v=
v_from_git=

# First see if there is a tarball-only version file.
# then try "git describe", then default.
if test -f $tarball_version_file
then
    v=`cat $tarball_version_file` || v=
    case $v in
        *$nl*) v= ;; # reject multi-line output
        [0-9]*) ;;
        *) v= ;;
    esac
    test "x$v" = x \
        && echo "$0: WARNING: $tarball_version_file is missing or damaged" 1>&2
fi

if test "x$v" != x
then
    : # use $v
# Otherwise, if there is at least one git commit involving the working
# directory, and "git describe" output looks sensible, use that to
# derive a version string.
elif test "`git log -1 --pretty=format:x . 2>&1`" = x \
    && v=`git describe --abbrev=4 --match="$prefix*" HEAD 2>/dev/null \
          || git describe --abbrev=4 HEAD 2>/dev/null` \
    && v=`printf '%s\n' "$v" | sed "$tag_sed_script"` \
    && case $v in
         $prefix[0-9]*) ;;
         *) (exit 1) ;;
       esac
then
    # Is this a new git that lists number of commits since the last
    # tag or the previous older version that did not?
    #   Newer: v6.10-77-g0f8faeb
    #   Older: v6.10-g0f8faeb
    case $v in
        *-*-*) : git describe is okay three part flavor ;;
        *-*)
            : git describe is older two part flavor
            # Recreate the number of commits and rewrite such that the
            # result is the same as if we were using the newer version
            # of git describe.
            vtag=`echo "$v" | sed 's/-.*//'`
            commit_list=`git rev-list "$vtag"..HEAD 2>/dev/null` \
                || { commit_list=failed;
                     echo "$0: WARNING: git rev-list failed" 1>&2; }
            numcommits=`echo "$commit_list" | wc -l`
            v=`echo "$v" | sed "s/\(.*\)-\(.*\)/\1-$numcommits-\2/"`;
            test "$commit_list" = failed && v=UNKNOWN
            ;;
    esac

    # Change the first '-' to a '.', so version-comparing tools work properly.
    # Remove the "g" in git describe's output string, to save a byte.
    v=`echo "$v" | sed 's/-/./;s/\(.*\)-g/\1-/'`;
    v_from_git=1
elif test "x$fallback" = x || git --version >/dev/null 2>&1; then
    v=UNKNOWN
else
    v=$fallback
fi

v=`echo "$v" |sed "s/^$prefix//"`

# Test whether to append the "-dirty" suffix only if the version
# string we're using came from git.  I.e., skip the test if it's "UNKNOWN"
# or if it came from .tarball-version.
if test "x$v_from_git" != x; then
  # Don't declare a version "dirty" merely because a timestamp has changed.
  git update-index --refresh > /dev/null 2>&1

  dirty=`exec 2>/dev/null;git diff-index --name-only HEAD` || dirty=
  case "$dirty" in
      '') ;;
      *) # Append the suffix only if there isn't one already.
          case $v in
            *-dirty) ;;
            *) v="$v-dirty" ;;
          esac ;;
  esac
fi

# Omit the trailing newline, so that m4_esyscmd can use the result directly.
printf %s "$v"

# Local variables:
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC0"
# time-stamp-end: "; # UTC"
# End:

path: build-aux/git-version-gen


code:
eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}'
  & eval 'exec perl -wS "$0" $argv:q'
    if 0;
# Convert git log output to ChangeLog format.

my $VERSION = '2012-07-29 06:11'; # UTC
# The definition above must lie within the first 8 lines in order
# for the Emacs time-stamp write hook (at end) to update it.
# If you change this file with Emacs, please let the write hook
# do its job.  Otherwise, update this string manually.

# Copyright (C) 2008-2013 Free Software Foundation, Inc.

# This program 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.

# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

# Written by Jim Meyering

use strict;
use warnings;
use Getopt::Long;
use POSIX qw(strftime);

(my $ME = $0) =~ s|.*/||;

# use File::Coda; # http://meyering.net/code/Coda/
END {
  defined fileno STDOUT or return;
  close STDOUT and return;
  warn "$ME: failed to close standard output: $!\n";
  $? ||= 1;
}

sub usage ($)
{
  my ($exit_code) = @_;
  my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR);
  if ($exit_code != 0)
    {
      print $STREAM "Try '$ME --help' for more information.\n";
    }
  else
    {
      print $STREAM <<EOF;
Usage: $ME [OPTIONS] [ARGS]

Convert git log output to ChangeLog format.  If present, any ARGS
are passed to "git log".  To avoid ARGS being parsed as options to
$ME, they may be preceded by '--'.

OPTIONS:

   --amend=FILE FILE maps from an SHA1 to perl code (i.e., s/old/new/) that
                  makes a change to SHA1's commit log text or metadata.
   --append-dot append a dot to the first line of each commit message if
                  there is no other punctuation or blank at the end.
   --no-cluster never cluster commit messages under the same date/author
                  header; the default is to cluster adjacent commit messages
                  if their headers are the same and neither commit message
                  contains multiple paragraphs.
   --srcdir=DIR the root of the source tree, from which the .git/
                  directory can be derived.
   --since=DATE convert only the logs since DATE;
                  the default is to convert all log entries.
   --format=FMT set format string for commit subject and body;
                  see 'man git-log' for the list of format metacharacters;
                  the default is '%s%n%b%n'
   --strip-tab  remove one additional leading TAB from commit message lines.
   --strip-cherry-pick  remove data inserted by "git cherry-pick";
                  this includes the "cherry picked from commit ..." line,
                  and the possible final "Conflicts:" paragraph.
   --help       display this help and exit
   --version    output version information and exit

EXAMPLE:

  $ME --since=2008-01-01 > ChangeLog
  $ME -- -n 5 foo > last-5-commits-to-branch-foo

SPECIAL SYNTAX:

The following types of strings are interpreted specially when they appear
at the beginning of a log message line.  They are not copied to the output.

  Copyright-paperwork-exempt: Yes
    Append the "(tiny change)" notation to the usual "date name email"
    ChangeLog header to mark a change that does not require a copyright
    assignment.
  Co-authored-by: Joe User <user\@example.com>
    List the specified name and email address on a second
    ChangeLog header, denoting a co-author.
  Signed-off-by: Joe User <user\@example.com>
    These lines are simply elided.

In a FILE specified via --amend, comment lines (starting with "#") are ignored.
FILE must consist of <SHA,CODE+> pairs where SHA is a 40-byte SHA1 (alone on
a line) referring to a commit in the current project, and CODE refers to one
or more consecutive lines of Perl code.  Pairs must be separated by one or
more blank line.

Here is sample input for use with --amend=FILE, from coreutils:

3a169f4c5d9159283548178668d2fae6fced3030
# fix typo in title:
s/all tile types/all file types/

1379ed974f1fa39b12e2ffab18b3f7a607082202
# Due to a bug in vc-dwim, I mis-attributed a patch by Paul to myself.
# Change the author to be Paul.  Note the escaped "@":
s,Jim .*>,Paul Eggert <eggert\\\@cs.ucla.edu>,

EOF
    }
  exit $exit_code;
}

# If the string $S is a well-behaved file name, simply return it.
# If it contains white space, quotes, etc., quote it, and return the new string.
sub shell_quote($)
{
  my ($s) = @_;
  if ($s =~ m![^\w+/.,-]!)
    {
      # Convert each single quote to '\''
      $s =~ s/\'/\'\\\'\'/g;
      # Then single quote the string.
      $s = "'$s'";
    }
  return $s;
}

sub quoted_cmd(@)
{
  return join (' ', map {shell_quote $_} @_);
}

# Parse file F.
# Comment lines (starting with "#") are ignored.
# F must consist of <SHA,CODE+> pairs where SHA is a 40-byte SHA1
# (alone on a line) referring to a commit in the current project, and
# CODE refers to one or more consecutive lines of Perl code.
# Pairs must be separated by one or more blank line.
sub parse_amend_file($)
{
  my ($f) = @_;

  open F, '<', $f
    or die "$ME: $f: failed to open for reading: $!\n";

  my $fail;
  my $h = {};
  my $in_code = 0;
  my $sha;
  while (defined (my $line = <F>))
    {
      $line =~ /^\#/
        and next;
      chomp $line;
      $line eq ''
        and $in_code = 0, next;

      if (!$in_code)
        {
          $line =~ /^([0-9a-fA-F]{40})$/
            or (warn "$ME: $f:$.: invalid line; expected an SHA1\n"),
              $fail = 1, next;
          $sha = lc $1;
          $in_code = 1;
          exists $h->{$sha}
            and (warn "$ME: $f:$.: duplicate SHA1\n"),
              $fail = 1, next;
        }
      else
        {
          $h->{$sha} ||= '';
          $h->{$sha} .= "$line\n";
        }
    }
  close F;

  $fail
    and exit 1;

  return $h;
}

# git_dir_option $SRCDIR
#
# From $SRCDIR, the --git-dir option to pass to git (none if $SRCDIR
# is undef).  Return as a list (0 or 1 element).
sub git_dir_option($)
{
  my ($srcdir) = @_;
  my @res = ();
  if (defined $srcdir)
    {
      my $qdir = shell_quote $srcdir;
      my $cmd = "cd $qdir && git rev-parse --show-toplevel";
      my $qcmd = shell_quote $cmd;
      my $git_dir = qx($cmd);
      defined $git_dir
        or die "$ME: cannot run $qcmd: $!\n";
      $? == 0
        or die "$ME: $qcmd had unexpected exit code or signal ($?)\n";
      chomp $git_dir;
      push @res, "--git-dir=$git_dir/.git";
    }
  @res;
}

{
  my $since_date;
  my $format_string = '%s%n%b%n';
  my $amend_file;
  my $append_dot = 0;
  my $cluster = 1;
  my $strip_tab = 0;
  my $strip_cherry_pick = 0;
  my $srcdir;
  GetOptions
    (
     help => sub { usage 0 },
     version => sub { print "$ME version $VERSION\n"; exit },
     'since=s' => \$since_date,
     'format=s' => \$format_string,
     'amend=s' => \$amend_file,
     'append-dot' => \$append_dot,
     'cluster!' => \$cluster,
     'strip-tab' => \$strip_tab,
     'strip-cherry-pick' => \$strip_cherry_pick,
     'srcdir=s' => \$srcdir,
    ) or usage 1;

  defined $since_date
    and unshift @ARGV, "--since=$since_date";

  # This is a hash that maps an SHA1 to perl code (i.e., s/old/new/)
  # that makes a correction in the log or attribution of that commit.
  my $amend_code = defined $amend_file ? parse_amend_file $amend_file : {};

  my @cmd = ('git',
             git_dir_option $srcdir,
             qw(log --log-size),
             '--pretty=format:%H:%ct  %an  <%ae>%n%n'.$format_string, @ARGV);
  open PIPE, '-|', @cmd
    or die ("$ME: failed to run '". quoted_cmd (@cmd) ."': $!\n"
            . "(Is your Git too old?  Version 1.5.1 or later is required.)\n");

  my $prev_multi_paragraph;
  my $prev_date_line = '';
  my @prev_coauthors = ();
  while (1)
    {
      defined (my $in = <PIPE>)
        or last;
      $in =~ /^log size (\d+)$/
        or die "$ME:$.: Invalid line (expected log size):\n$in";
      my $log_nbytes = $1;

      my $log;
      my $n_read = read PIPE, $log, $log_nbytes;
      $n_read == $log_nbytes
        or die "$ME:$.: unexpected EOF\n";

      # Extract leading hash.
      my ($sha, $rest) = split ':', $log, 2;
      defined $sha
        or die "$ME:$.: malformed log entry\n";
      $sha =~ /^[0-9a-fA-F]{40}$/
        or die "$ME:$.: invalid SHA1: $sha\n";

      # If this commit's log requires any transformation, do it now.
      my $code = $amend_code->{$sha};
      if (defined $code)
        {
          eval 'use Safe';
          my $s = new Safe;
          # Put the unpreprocessed entry into "$_".
          $_ = $rest;

          # Let $code operate on it, safely.
          my $r = $s->reval("$code")
            or die "$ME:$.:$sha: failed to eval \"$code\":\n$@\n";

          # Note that we've used this entry.
          delete $amend_code->{$sha};

          # Update $rest upon success.
          $rest = $_;
        }

      # Remove lines inserted by "git cherry-pick".
      if ($strip_cherry_pick)
        {
          $rest =~ s/^\s*Conflicts:\n.*//sm;
          $rest =~ s/^\s*\(cherry picked from commit [\da-f]+\)\n//m;
        }

      my @line = split "\n", $rest;
      my $author_line = shift @line;
      defined $author_line
        or die "$ME:$.: unexpected EOF\n";
      $author_line =~ /^(\d+)  (.*>)$/
        or die "$ME:$.: Invalid line "
          . "(expected date/author/email):\n$author_line\n";

      # Format 'Copyright-paperwork-exempt: Yes' as a standard ChangeLog
      # `(tiny change)' annotation.
      my $tiny = (grep (/^Copyright-paperwork-exempt:\s+[Yy]es$/, @line)
                  ? '  (tiny change)' : '');

      my $date_line = sprintf "%s  %s$tiny\n",
        strftime ("%F", localtime ($1)), $2;

      my @coauthors = grep /^Co-authored-by:.*$/, @line;
      # Omit meta-data lines we've already interpreted.
      @line = grep !/^(?:Signed-off-by:[ ].*>$
                       |Co-authored-by:[ ]
                       |Copyright-paperwork-exempt:[ ]
                       )/x, @line;

      # Remove leading and trailing blank lines.
      if (@line)
        {
          while ($line[0] =~ /^\s*$/) { shift @line; }
          while ($line[$#line] =~ /^\s*$/) { pop @line; }
        }

      # Record whether there are two or more paragraphs.
      my $multi_paragraph = grep /^\s*$/, @line;

      # Format 'Co-authored-by: A U Thor <email@example.com>' lines in
      # standard multi-author ChangeLog format.
      for (@coauthors)
        {
          s/^Co-authored-by:\s*/\t    /;
          s/\s*</  </;

          /<.*?@.*\..*>/
            or warn "$ME: warning: missing email address for "
              . substr ($_, 5) . "\n";
        }

      # If clustering of commit messages has been disabled, if this header
      # would be different from the previous date/name/email/coauthors header,
      # or if this or the previous entry consists of two or more paragraphs,
      # then print the header.
      if ( ! $cluster
          || $date_line ne $prev_date_line
          || "@coauthors" ne "@prev_coauthors"
          || $multi_paragraph
          || $prev_multi_paragraph)
        {
          $prev_date_line eq ''
            or print "\n";
          print $date_line;
          @coauthors
            and print join ("\n", @coauthors), "\n";
        }
      $prev_date_line = $date_line;
      @prev_coauthors = @coauthors;
      $prev_multi_paragraph = $multi_paragraph;

      # If there were any lines
      if (@line == 0)
        {
          warn "$ME: warning: empty commit message:\n  $date_line\n";
        }
      else
        {
          if ($append_dot)
            {
              # If the first line of the message has enough room, then
              if (length $line[0] < 72)
                {
                  # append a dot if there is no other punctuation or blank
                  # at the end.
                  $line[0] =~ /[[:punct:]\s]$/
                    or $line[0] .= '.';
                }
            }

          # Remove one additional leading TAB from each line.
          $strip_tab
            and map { s/^\t// } @line;

          # Prefix each non-empty line with a TAB.
          @line = map { length $_ ? "\t$_" : '' } @line;

          print "\n", join ("\n", @line), "\n";
        }

      defined ($in = <PIPE>)
        or last;
      $in ne "\n"
        and die "$ME:$.: unexpected line:\n$in";
    }

  close PIPE
    or die "$ME: error closing pipe from " . quoted_cmd (@cmd) . "\n";
  # FIXME-someday: include $PROCESS_STATUS in the diagnostic

  # Complain about any unused entry in the --amend=F specified file.
  my $fail = 0;
  foreach my $sha (keys %$amend_code)
    {
      warn "$ME:$amend_file: unused entry: $sha\n";
      $fail = 1;
    }

  exit $fail;
}

# Local Variables:
# mode: perl
# indent-tabs-mode: nil
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "my $VERSION = '"
# time-stamp-format: "%:y-%02m-%02d %02H:%02M"
# time-stamp-time-zone: "UTC"
# time-stamp-end: "'; # UTC"
# End:

path: build-aux/gitlog-to-changelog


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

;;; This program replicates the behavior of Hydra's 'hydra-eval-guile-job'.
;;; It evaluates the Hydra job defined by the program passed as its first
;;; arguments and outputs an sexp of the jobs on standard output.

(use-modules (guix store)
             (guix git-download)
             ((guix build utils) #:select (with-directory-excursion))
             ((guix ui) #:select (build-notifier))
             (srfi srfi-19)
             (ice-9 match)
             (ice-9 pretty-print)
             (ice-9 format))

(define %top-srcdir
  (and=> (assq-ref (current-source-location) 'filename)
         (lambda (file)
           (canonicalize-path
            (string-append (dirname file) "/../..")))))

(define %user-module
  ;; Hydra user module.
  (let ((m (make-module)))
    (beautify-user-module! m)
    m))

(define (call-with-time thunk kont)
  "Call THUNK and pass KONT the elapsed time followed by THUNK's return
values."
  (let* ((start  (current-time time-monotonic))
         (result (call-with-values thunk list))
         (end    (current-time time-monotonic)))
    (apply kont (time-difference end start) result)))

(define (call-with-time-display thunk)
  "Call THUNK and write to the current output port its duration."
  (call-with-time thunk
    (lambda (time . results)
      (format #t "~,3f seconds~%"
              (+ (time-second time)
                 (/ (time-nanosecond time) 1e9)))
      (apply values results))))

(define (assert-valid-job job thing)
  "Raise an error if THING is not an alist with a valid 'derivation' entry.
Otherwise return THING."
  (unless (and (list? thing)
               (and=> (assoc-ref thing 'derivation)
                      (lambda (value)
                        (and (string? value)
                             (string-suffix? ".drv" value)))))
    (error "job did not produce a valid alist" job thing))
  thing)

;; Without further ado...
(match (command-line)
  ((command file cuirass? ...)
   ;; Load FILE, a Scheme file that defines Hydra jobs.
   (let ((port (current-output-port))
         (real-build-things build-things))
     (with-store store
       ;; Make sure we don't resort to substitutes.
       (set-build-options store
                          #:use-substitutes? #f
                          #:substitute-urls '())

       ;; The evaluation of Guix itself requires building a "trampoline"
       ;; program, and possibly everything it depends on.  Thus, allow builds
       ;; but print a notification.
       (with-build-handler (build-notifier #:use-substitutes? #f)

         ;; Add %TOP-SRCDIR to the store with a proper Git predicate so we work
         ;; from a clean checkout
         (let ((source (add-to-store store "guix-source" #t
                                     "sha256" %top-srcdir
                                     #:select? (git-predicate %top-srcdir))))
           (with-directory-excursion source
             (save-module-excursion
              (lambda ()
                (set-current-module %user-module)
                (format (current-error-port)
                        "loading '~a' relative to '~a'...~%"
                        file source)
                (primitive-load file))))

           ;; Call the entry point of FILE and print the resulting job sexp.
           (pretty-print
            (match ((module-ref %user-module
                                (if (equal? cuirass? "cuirass")
                                    'cuirass-jobs
                                    'hydra-jobs))
                    store `((guix
                             . ((file-name . ,source)))))
              (((names . thunks) ...)
               (map (lambda (job thunk)
                      (format (current-error-port) "evaluating '~a'... " job)
                      (force-output (current-error-port))
                      (cons job
                            (assert-valid-job job
                                              (call-with-time-display thunk))))
                    names thunks)))
            port))))))
  ((command _ ...)
   (format (current-error-port) "Usage: ~a FILE [cuirass]
Evaluate the Hydra or Cuirass jobs defined in FILE.~%"
           command)
   (exit 1)))

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


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.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/>.

;;;
;;; This file defines build jobs for the Hydra continuation integration
;;; tool.
;;;

(use-modules (guix inferior) (guix channels)
             (guix)
             (guix ui)
             (srfi srfi-1)
             (ice-9 match))

;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
;; port to the bit bucket, let us write to the error port instead.
(setvbuf (current-error-port) 'line)
(set-current-output-port (current-error-port))

(define (find-current-checkout arguments)
  "Find the first checkout of ARGUMENTS that provided the current file.
Return #f if no such checkout is found."
  (let ((current-root
         (canonicalize-path
          (string-append (dirname (current-filename)) "/../.."))))
    (find (lambda (argument)
            (and=> (assq-ref argument 'file-name)
                   (lambda (name)
                     (string=? name current-root)))) arguments)))

(define (hydra-jobs store arguments)
  "Return a list of jobs where each job is a NAME/THUNK pair."

  (define checkout
    (find-current-checkout arguments))

  (define commit
    (assq-ref checkout 'revision))

  (define source
    (assq-ref checkout 'file-name))

  (define instance
    (checkout->channel-instance source #:commit commit))

  (define derivation
    ;; Compute the derivation of Guix for COMMIT.
    (run-with-store store
      (channel-instances->derivation (list instance))))

  ;; TODO: Remove 'show-what-to-build' call when Cuirass' 'evaluate' scripts
  ;; uses 'with-build-handler'.
  (show-what-to-build store (list derivation))
  (build-derivations store (list derivation))

  ;; Open an inferior for the just-built Guix.
  (let ((inferior (open-inferior (derivation->output-path derivation))))
    (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)

    (map (match-lambda
           ((name . fields)
            ;; Hydra expects a thunk, so here it is.
            (cons name (lambda () fields))))
         (inferior-eval-with-store
          inferior store
          `(lambda (store)
             (map (match-lambda
                    ((name . thunk)
                     (cons name (thunk))))
                  (hydra-jobs store '((superior-guix-checkout . ,checkout)
                                      ,@arguments))))))))


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

;;;
;;; This file defines a continuous integration job to build the same modular
;;; Guix as 'guix pull', which is defined in (guix self).
;;;

(use-modules (guix store)
             (guix config)
             (guix utils)
             ((guix packages) #:select (%hydra-supported-systems))
             (guix derivations)
             (guix monads)
             ((guix licenses) #:prefix license:)
             (srfi srfi-1)
             (ice-9 match))

;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
;; port to the bit bucket, let us write to the error port instead.
(setvbuf (current-error-port) 'line)
(set-current-output-port (current-error-port))

(define* (build-job store source version system)
  "Return a Hydra job a list building the modular Guix derivation from SOURCE
for SYSTEM.  Use VERSION as the version identifier."
  (lambda ()
    (define build
      (primitive-load (string-append source "/build-aux/build-self.scm")))

    `((derivation . ,(derivation-file-name
                      (run-with-store store
                        (build source #:version version #:system system
                               #:pull-version 1
                               #:guile-version "2.2")))) ;the latest 2.2.x
      (description . "Modular Guix")
      (long-description
       . "This is the modular Guix package as produced by 'guix pull'.")
      (license . ,license:gpl3+)
      (home-page . ,%guix-home-page-url)
      (maintainers . (,%guix-bug-report-address)))))

(define (hydra-jobs store arguments)
  "Return Hydra jobs."
  (define systems
    (match (assoc-ref arguments 'systems)
      (#f              %hydra-supported-systems)
      ((lst ...)       lst)
      ((? string? str) (call-with-input-string str read))))

  (define guix-checkout
    (or (assq-ref arguments 'guix)                ;Hydra on hydra
        (assq-ref arguments 'guix-modular)))      ;Cuirass on berlin

  (define version
    (or (assq-ref guix-checkout 'revision)
        "0.unknown"))

  (let ((file (assq-ref guix-checkout 'file-name)))
    (format (current-error-port) "using checkout ~s (~s; arguments: ~s)~%"
            guix-checkout file arguments)

    (map (lambda (system)
           (let ((name (string->symbol
                        (string-append "guix." system))))
             `(,name
               . ,(build-job store file version system))))
         systems)))


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

;;;
;;; This file defines build jobs of Guix itself for the Hydra continuation
;;; integration tool.
;;;

;; Attempt to use our very own Guix modules.
(eval-when (expand load eval)

  ;; Ignore any available .go, and force recompilation.  This is because our
  ;; checkout in the store has mtime set to the epoch, and thus .go files look
  ;; newer, even though they may not correspond.
  (set! %fresh-auto-compile #t)

  ;; Display which files are loaded.
  (set! %load-verbosely #t)

  (and=> (assoc-ref (current-source-location) 'filename)
         (lambda (file)
           (let ((dir (string-append (dirname file) "/../..")))
             (format (current-error-port) "prepending ~s to the load path~%"
                     dir)
             (set! %load-path (cons dir %load-path))))))

(use-modules (guix store)
             (guix packages)
             (guix utils)
             (guix grafts)
             (guix derivations)
             (guix build-system gnu)
             (gnu packages package-management)
             (srfi srfi-1)
             (srfi srfi-26)
             (ice-9 match))

;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
;; port to the bit bucket, let us write to the error port instead.
(setvbuf (current-error-port) _IOLBF)
(set-current-output-port (current-error-port))

(define* (package->alist store package system
                         #:optional (package-derivation package-derivation))
  "Convert PACKAGE to an alist suitable for Hydra."
  `((derivation . ,(derivation-file-name
                    (parameterize ((%graft? #f))
                      (package-derivation store package system
                                          #:graft? #f))))
    (description . ,(package-synopsis package))
    (long-description . ,(package-description package))
    (license . ,(package-license package))
    (home-page . ,(package-home-page package))
    (maintainers . ("bug-guix@gnu.org"))))

(define (hydra-jobs store arguments)
  "Return Hydra jobs."
  (define systems
    (match (filter-map (match-lambda
                        (('system . value)
                         value)
                        (_ #f))
                       arguments)
      ((lst ..1)
       lst)
      (_
       (list (%current-system)))))

  (define guix-checkout
    (assq-ref arguments 'guix))

  (let ((file (assq-ref guix-checkout 'file-name)))
    (format (current-error-port) "using checkout ~s (~s)~%"
            guix-checkout file)

    `((tarball . ,(cute package->alist store
                        (dist-package guix file)
                        (%current-system)))

      ,@(map (lambda (system)
               (let ((name (string->symbol
                            (string-append "guix." system))))
                 `(,name
                   . ,(cute package->alist store
                            (package
                              (inherit guix)
                              (version "latest")
                              (source file))
                            system))))
             %hydra-supported-systems))))


code:
#!/bin/sh

# GNU Guix --- Functional package management for GNU
# Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2017 Eric Bavier <bavier@cray.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/>.

# Usage: ./pre-inst-env COMMAND ARG...
#
# Run COMMAND in a pre-installation environment.  Typical use is
# "./pre-inst-env guix build hello".

# By default we may end up with absolute directory names that contain '..',
# which get into $GUILE_LOAD_PATH, leading to '..' in the module file names
# recorded by Guile.  To avoid that, make sure we get a real absolute
# directory name.  Additionally, use '-P' to get the canonical directory name
# so that Guile's 'relative' %file-port-name-canonicalization can actually
# work (see <http://bugs.gnu.org/17935>.)
abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd -P`"
abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd -P`"

GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH

# Define $PATH so that `guix' and friends are easily found.

PATH="$abs_top_builddir/scripts:$abs_top_builddir:$PATH"
export PATH

# The daemon invokes 'guix'; tell it which one to use.
GUIX="$abs_top_builddir/scripts/guix"
export GUIX

# Define $GUIX_UNINSTALLED to prevent `guix' from
# prepending @guilemoduledir@ to the Guile load paths.

GUIX_UNINSTALLED=1
export GUIX_UNINSTALLED

exec "$@"