diff options
author | Ricardo Wurmus <rekado@elephly.net> | 2017-05-24 12:05:47 +0200 |
---|---|---|
committer | Ricardo Wurmus <rekado@elephly.net> | 2017-05-24 12:05:47 +0200 |
commit | d1a914082b7e53636f9801769ef96218b2125c4b (patch) | |
tree | 998805fc59fe0b1bb105b24a6a79fff646257d96 /build-aux | |
parent | 657fb6c947d94cf946f29cd24e88bd080c01ff0a (diff) | |
parent | ae548434337cddf9677a4cd52b9370810b2cc9b6 (diff) | |
download | guix-d1a914082b7e53636f9801769ef96218b2125c4b.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'build-aux')
-rw-r--r-- | build-aux/build-self.scm | 88 | ||||
-rw-r--r-- | build-aux/check-available-binaries.scm | 9 | ||||
-rw-r--r-- | build-aux/check-final-inputs-self-contained.scm | 6 | ||||
-rw-r--r-- | build-aux/compile-all.scm | 5 | ||||
-rw-r--r-- | build-aux/download.scm | 20 | ||||
-rwxr-xr-x | build-aux/git-version-gen | 226 | ||||
-rw-r--r-- | build-aux/hydra/evaluate.scm | 9 | ||||
-rw-r--r-- | build-aux/hydra/gnu-system.scm | 2 | ||||
-rw-r--r-- | build-aux/update-NEWS.scm | 161 | ||||
-rw-r--r-- | build-aux/update-guix-package.scm | 144 |
10 files changed, 634 insertions, 36 deletions
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index cc702490df..a1335fea1d 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix config) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (ice-9 match) #:export (build)) ;;; Commentary: @@ -58,11 +59,43 @@ (define xz (first (find-best-packages-by-name "xz" #f))) +(define (false-if-wrong-guile package) + "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., +2.0 instead of 2.2), otherwise return PACKAGE." + (let ((guile (any (match-lambda + ((label (? package? dep) _ ...) + (and (string=? (package-name dep) "guile") + dep))) + (package-direct-inputs package)))) + (and (or (not guile) + (string-prefix? (effective-version) + (package-version guile))) + package))) + +(define (package-for-current-guile . names) + "Return the package with one of the given NAMES that depends on the current +Guile major version (2.0 or 2.2), or #f if none of the packages matches." + (let loop ((names names)) + (match names + (() + #f) + ((name rest ...) + (match (find-best-packages-by-name name #f) + (() + (loop rest)) + ((first _ ...) + (or (false-if-wrong-guile first) + (loop rest)))))))) + (define guile-json - (first (find-best-packages-by-name "guile-json" #f))) + (package-for-current-guile "guile-json" + "guile2.2-json" + "guile2.0-json")) (define guile-ssh - (first (find-best-packages-by-name "guile-ssh" #f))) + (package-for-current-guile "guile-ssh" + "guile2.2-ssh" + "guile2.0-ssh")) ;; The actual build procedure. @@ -80,6 +113,17 @@ person's version identifier." ;; XXX: Replace with a Git commit id. (date->string (current-date 0) "~Y~m~d.~H")) +(define (guile-for-build) + "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently +running Guile." + (package->derivation (cond-expand + (guile-2.2 + (canonical-package + (specification->package "guile@2.2"))) + (else + (canonical-package + (specification->package "guile@2.0")))))) + ;; The procedure below is our return value. (define* (build source #:key verbose? (version (date-version-string)) @@ -104,15 +148,19 @@ files." #~(begin (use-modules (guix build pull)) - (let ((json (string-append #$guile-json "/share/guile/site/2.0"))) + (let ((json (string-append #$guile-json "/share/guile/site/" + #$(effective-version)))) (set! %load-path - (cons* json - (string-append #$guile-ssh "/share/guile/site/2.0") - %load-path)) + (cons* json + (string-append #$guile-ssh "/share/guile/site/" + #$(effective-version)) + %load-path)) (set! %load-compiled-path - (cons* json - (string-append #$guile-ssh "/lib/guile/2.0/site-ccache") - %load-compiled-path))) + (cons* json + (string-append #$guile-ssh "/lib/guile/" + #$(effective-version) + "/site-ccache") + %load-compiled-path))) ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was ;; broken: libguile-ssh could not be found. Work around that. @@ -146,13 +194,21 @@ files." (current-error-port) (%make-void-port "w"))))) - (gexp->derivation "guix-latest" builder - #:modules '((guix build pull) - (guix build utils)) + (mlet %store-monad ((guile (guile-for-build))) + (gexp->derivation "guix-latest" builder + #:modules '((guix build pull) + (guix build utils) + + ;; Closure of (guix modules). + (guix modules) + (guix memoization) + (guix sets)) + + ;; Arrange so that our own (guix build …) modules are + ;; used. + #:module-path (list (top-source-directory)) - ;; Arrange so that our own (guix build …) modules are - ;; used. - #:module-path (list (top-source-directory)))) + #:guile-for-build guile))) ;; This file is loaded by 'guix pull'; return it the build procedure. build diff --git a/build-aux/check-available-binaries.scm b/build-aux/check-available-binaries.scm index 0060a8669e..b832d99935 100644 --- a/build-aux/check-available-binaries.scm +++ b/build-aux/check-available-binaries.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,10 +38,13 @@ %hydra-supported-systems)) (cross (map (cut package-cross-derivation store %bootstrap-tarballs <>) - '("mips64el-linux-gnuabi64"))) + '("mips64el-linux-gnu" + "arm-linux-gnueabihf"))) (total (append native cross))) - (set-build-options store #:use-substitutes? #t) + (set-build-options store + #:use-substitutes? #t + #:substitute-urls %default-substitute-urls) (let* ((total (map derivation->output-path total)) (available (substitutable-paths store total)) (missing (lset-difference string=? total available))) diff --git a/build-aux/check-final-inputs-self-contained.scm b/build-aux/check-final-inputs-self-contained.scm index dc44c4b636..dfb6a72f24 100644 --- a/build-aux/check-final-inputs-self-contained.scm +++ b/build-aux/check-final-inputs-self-contained.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,7 @@ if it does." (let ((references (substitutable-references substitute))) (when (any (cut string-contains <> "boot") references) - (leave (_ "'~a' refers to bootstrap inputs: ~s~%") + (leave (G_ "'~a' refers to bootstrap inputs: ~s~%") (substitutable-path substitute) references)))) (define (test-final-inputs store system) @@ -71,7 +71,7 @@ refer to the bootstrap tools." (string=? (substitutable-path substitute) dir)) available) - (leave (_ "~a (system: ~a) has no substitute~%") + (leave (G_ "~a (system: ~a) has no substitute~%") dir system))) inputs) diff --git a/build-aux/compile-all.scm b/build-aux/compile-all.scm index d077d75229..147bb80196 100644 --- a/build-aux/compile-all.scm +++ b/build-aux/compile-all.scm @@ -24,7 +24,10 @@ (guix build utils)) (define warnings - '(unsupported-warning format unbound-variable arity-mismatch)) + ;; FIXME: 'format' is missing because it reports "non-literal format + ;; strings" due to the fact that we use 'G_' instead of '_'. We'll need + ;; help from Guile to solve this. + '(unsupported-warning unbound-variable arity-mismatch)) (define host (getenv "host")) diff --git a/build-aux/download.scm b/build-aux/download.scm index 0e98bef55b..8dfa914603 100644 --- a/build-aux/download.scm +++ b/build-aux/download.scm @@ -42,17 +42,15 @@ (match (string-tokenize file (char-set-complement (char-set #\/))) ((_ ... system basename) (string->uri - (match system - ("aarch64-linux" - (string-append "http://flashner.co.il/guix/bootstrap/aarch64-linux" - "/20170217/" basename)) - (_ (string-append %url-base "/" system - (match system - ("armhf-linux" - "/20150101/") - (_ - "/20131110/")) - basename))))))) + (string-append %url-base "/" system + (match system + ("aarch64-linux" + "/20170217/") + ("armhf-linux" + "/20150101/") + (_ + "/20131110/")) + basename))))) (match (command-line) ((_ file expected-hash) diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen new file mode 100755 index 0000000000..079849d5e5 --- /dev/null +++ b/build-aux/git-version-gen @@ -0,0 +1,226 @@ +#!/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: diff --git a/build-aux/hydra/evaluate.scm b/build-aux/hydra/evaluate.scm index ab10253f31..cc6a4b9492 100644 --- a/build-aux/hydra/evaluate.scm +++ b/build-aux/hydra/evaluate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +32,13 @@ (beautify-user-module! m) m)) +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + (define (call-with-time thunk kont) "Call THUNK and pass KONT the elapsed time followed by THUNK's return values." diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index 507c6abe0e..b1faa2265a 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -111,7 +111,7 @@ SYSTEM." ;; chain.) (list gcc-4.8 gcc-4.9 gcc-5 glibc binutils gmp mpfr mpc coreutils findutils diffutils patch sed grep - gawk gnu-gettext hello guile-2.0 zlib gzip xz + gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz %bootstrap-binaries-tarball %binutils-bootstrap-tarball (%glibc-bootstrap-tarball) diff --git a/build-aux/update-NEWS.scm b/build-aux/update-NEWS.scm new file mode 100644 index 0000000000..2e8f68c9a8 --- /dev/null +++ b/build-aux/update-NEWS.scm @@ -0,0 +1,161 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; This script updates the list of new and updated packages in 'NEWS'. +;;; +;;; Code: + +(use-modules (gnu) (guix) + (guix build utils) + ((guix ui) #:select (fill-paragraph)) + (srfi srfi-1) + (srfi srfi-11) + (ice-9 match) + (ice-9 rdelim) + (ice-9 regex) + (ice-9 pretty-print)) + +(define %header-rx + (make-regexp "^\\* Changes in (version )?([0-9.]+) \\(since ([0-9.]+)\\)")) + +(define (NEWS->versions port) + "Return two values: the previous version and the current version as read +from PORT, which is an input port on the 'NEWS' file." + (let loop () + (let ((line (read-line port))) + (cond ((eof-object? line) + (error "failed to determine previous and current version" + port)) + ((regexp-exec %header-rx line) + => + (lambda (match) + (values (match:substring match 3) + (match:substring match 2)))) + (else + (loop)))))) + +(define (skip-to-org-heading port) + "Read from PORT until an Org heading is found." + (let loop () + (let ((next (peek-char port))) + (cond ((eqv? next #\*) + #t) + ((eof-object? next) + (error "next heading could not be found")) + (else + (read-line port) + (loop)))))) + +(define (rewrite-org-section input output heading-rx proc) + "Write to OUTPUT the text read from INPUT, but with the first Org section +matching HEADING-RX replaced by NEW-HEADING and CONTENTS." + (let loop () + (let ((line (read-line input))) + (cond ((eof-object? line) + (error "failed to match heading regexp" heading-rx)) + ((regexp-exec heading-rx line) + => + (lambda (match) + (proc match output) + (skip-to-org-heading input) + (dump-port input output) + #t)) + (else + (display line output) + (newline output) + (loop)))))) + +(define (enumeration->paragraph lst) + "Turn LST, a list of strings, into a single string that is a ready-to-print +paragraph." + (fill-paragraph (string-join (sort lst string<?) ", ") + 75)) + +(define (write-packages-added news-file old new) + "Write to NEWS-FILE the list of packages added between OLD and NEW." + (let ((added (lset-difference string=? (map car new) (map car old)))) + (with-atomic-file-replacement news-file + (lambda (input output) + (rewrite-org-section input output + (make-regexp "^(\\*+) (.*) new packages") + (lambda (match port) + (let ((stars (match:substring match 1))) + (format port + "~a ~a new packages~%~%~a~%~%" + stars (length added) + (enumeration->paragraph added))))))))) + +(define (write-packages-updates news-file old new) + "Write to NEWS-FILE the list of packages upgraded between OLD and NEW." + (let ((upgraded (filter-map (match-lambda + ((package . new-version) + (match (assoc package old) + ((_ . old-version) + (and (version>? new-version old-version) + (string-append package "@" + new-version))) + (_ #f)))) + new))) + (with-atomic-file-replacement news-file + (lambda (input output) + (rewrite-org-section input output + (make-regexp "^(\\*+) (.*) package updates") + (lambda (match port) + (let ((stars (match:substring match 1))) + (format port + "~a ~a package updates~%~%~a~%~%" + stars (length upgraded) + (enumeration->paragraph upgraded))))))))) + + +(define (main . args) + (match args + ((news-file data-directory) + ;; Don't browse things listed in the user's $GUIX_PACKAGE_PATH. Here we + ;; assume that the last item in (%package-module-path) is the distro + ;; directory. + (parameterize ((%package-module-path + (list (last (%package-module-path))))) + (define (package-file version) + (string-append data-directory "/packages-" + version ".txt")) + + (let-values (((previous-version new-version) + (call-with-input-file news-file NEWS->versions))) + (let* ((old (call-with-input-file (package-file previous-version) + read)) + (new (fold-packages (lambda (p r) + (alist-cons (package-name p) (package-version p) + r)) + '()))) + (call-with-output-file (package-file new-version) + (lambda (port) + (pretty-print new port))) + + (write-packages-added news-file old new) + (write-packages-updates news-file old new))))) + (x + (format (current-error-port) "Usage: update-NEWS NEWS-FILE DATA-DIRECTORY + +Update the list of new and updated packages in NEWS-FILE using the +previous-version package list from DATA-DIRECTORY.\n") + (exit 1)))) + +(apply main (cdr (command-line))) diff --git a/build-aux/update-guix-package.scm b/build-aux/update-guix-package.scm new file mode 100644 index 0000000000..9598872dfd --- /dev/null +++ b/build-aux/update-guix-package.scm @@ -0,0 +1,144 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; This scripts updates the definition of the 'guix' package in Guix for the +;;; current commit. It requires Git to be installed. +;;; +;;; Code: + +(use-modules (guix) + (guix git-download) + (guix upstream) + (guix utils) + (guix base32) + (guix build utils) + (gnu packages package-management) + (ice-9 match)) + +(define %top-srcdir + (string-append (current-source-directory) "/..")) + +(define version-controlled? + (git-predicate %top-srcdir)) + +(define (package-definition-location) + "Return the source properties of the definition of the 'guix' package." + (call-with-input-file (location-file (package-location guix)) + (lambda (port) + (let loop () + (match (read port) + ((? eof-object?) + (error "definition of 'guix' package could not be found" + (port-filename port))) + (('define-public 'guix value) + (source-properties value)) + (_ + (loop))))))) + +(define* (update-definition commit hash + #:key version old-hash) + "Return a one-argument procedure that takes a string, the definition of the +'guix' package, and returns a string, the update definition for VERSION, +COMMIT." + (define (linear-offset str line column) + ;; Return the offset in characters to reach LINE and COLUMN (both + ;; zero-indexed) in STR. + (call-with-input-string str + (lambda (port) + (let loop ((offset 0)) + (cond ((and (= (port-column port) column) + (= (port-line port) line)) + offset) + ((eof-object? (read-char port)) + (error "line and column not reached!" + str)) + (else + (loop (+ 1 offset)))))))) + + (define (update-hash str) + ;; Replace OLD-HASH with HASH in STR. + (string-replace-substring str + (bytevector->nix-base32-string old-hash) + (bytevector->nix-base32-string hash))) + + (lambda (str) + (match (call-with-input-string str read) + (('let (('version old-version) + ('commit old-commit) + ('revision old-revision)) + defn) + (let* ((location (source-properties defn)) + (line (assq-ref location 'line)) + (column 0) + (offset (linear-offset str line column))) + (string-append (format #f "(let ((version \"~a\") + (commit \"~a\") + (revision ~a))\n" + (or version old-version) + commit + (if (and version + (not (string=? version old-version))) + 0 + (+ 1 old-revision))) + (string-drop (update-hash str) offset)))) + (exp + (error "'guix' package definition is not as expected" exp))))) + + +(define (main . args) + (match args + ((commit version) + (with-store store + (let* ((source (add-to-store store + "guix-checkout" ;dummy name + #t "sha256" %top-srcdir + #:select? version-controlled?)) + (hash (query-path-hash store source)) + (location (package-definition-location)) + (old-hash (origin-sha256 (package-source guix)))) + (edit-expression location + (update-definition commit hash + #:old-hash old-hash + #:version version)) + + ;; Re-add SOURCE to the store, but this time under the real name used + ;; in the 'origin'. This allows us to build the package without + ;; having to make a real checkout; thus, it also works when working + ;; on a private branch. + (reload-module + (resolve-module '(gnu packages package-management))) + + (let* ((source (add-to-store store + (origin-file-name (package-source guix)) + #t "sha256" source)) + (root (store-path-package-name source))) + + ;; Add an indirect GC root for SOURCE in the current directory. + (false-if-exception (delete-file root)) + (symlink source root) + (add-indirect-root store root) + + (format #t "source code for commit ~a: ~a (GC root: ~a)~%" + commit source root))))) + ((commit) + ;; Automatically deduce the version and revision numbers. + (main commit #f)))) + +(apply main (cdr (command-line))) |