diff options
Diffstat (limited to 'etc')
| -rwxr-xr-x | etc/committer.scm.in | 250 | ||||
| -rw-r--r-- | etc/news.scm | 74 |
2 files changed, 324 insertions, 0 deletions
diff --git a/etc/committer.scm.in b/etc/committer.scm.in new file mode 100755 index 0000000000..2f247835f3 --- /dev/null +++ b/etc/committer.scm.in @@ -0,0 +1,250 @@ +#!@GUILE@ \ +--no-auto-compile -s +!# + +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This script stages and commits changes to package definitions. + +;;; Code: + +(import (sxml xpath) + (srfi srfi-1) + (srfi srfi-9) + (ice-9 format) + (ice-9 popen) + (ice-9 match) + (ice-9 rdelim) + (ice-9 textual-ports)) + +(define (read-excursion port) + "Read an expression from PORT and reset the port position before returning +the expression." + (let ((start (ftell port)) + (result (read port))) + (seek port start SEEK_SET) + result)) + +(define (surrounding-sexp port line-no) + "Return the top-level S-expression surrounding the change at line number +LINE-NO in PORT." + (let loop ((i (1- line-no)) + (last-top-level-sexp #f)) + (if (zero? i) + last-top-level-sexp + (match (peek-char port) + (#\( + (let ((sexp (read-excursion port))) + (read-line port) + (loop (1- i) sexp))) + (_ + (read-line port) + (loop (1- i) last-top-level-sexp)))))) + +(define-record-type <hunk> + (make-hunk file-name + old-line-number + new-line-number + diff) + hunk? + (file-name hunk-file-name) + ;; Line number before the change + (old-line-number hunk-old-line-number) + ;; Line number after the change + (new-line-number hunk-new-line-number) + ;; The full diff to be used with "git apply --cached" + (diff hunk-diff)) + +(define* (hunk->patch hunk #:optional (port (current-output-port))) + (let ((file-name (hunk-file-name hunk))) + (format port + "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a" + file-name file-name file-name file-name + (hunk-diff hunk)))) + +(define (diff-info) + "Read the diff and return a list of <hunk> values." + (let ((port (open-pipe* OPEN_READ + "git" "diff" + "--no-prefix" + ;; Do not include any context lines. This makes it + ;; easier to find the S-expression surrounding the + ;; change. + "--unified=0"))) + (define (extract-line-number line-tag) + (abs (string->number + (car (string-split line-tag #\,))))) + (define (read-hunk) + (reverse + (let loop ((lines '())) + (let ((line (read-line port 'concat))) + (cond + ((eof-object? line) lines) + ((or (string-prefix? "@@ " line) + (string-prefix? "diff --git" line)) + (unget-string port line) + lines) + (else (loop (cons line lines)))))))) + (define info + (let loop ((acc '()) + (file-name #f)) + (let ((line (read-line port))) + (cond + ((eof-object? line) acc) + ((string-prefix? "--- " line) + (match (string-split line #\space) + ((_ file-name) + (loop acc file-name)))) + ((string-prefix? "@@ " line) + (match (string-split line #\space) + ((_ old-start new-start . _) + (loop (cons (make-hunk file-name + (extract-line-number old-start) + (extract-line-number new-start) + (string-join (cons* line "\n" + (read-hunk)) "")) + acc) + file-name)))) + (else (loop acc file-name)))))) + (close-pipe port) + info)) + +(define (old-sexp hunk) + "Using the diff information in HUNK return the unmodified S-expression +corresponding to the top-level definition containing the staged changes." + ;; TODO: We can't seek with a pipe port... + (let* ((port (open-pipe* OPEN_READ + "git" "show" (string-append "HEAD:" + (hunk-file-name hunk)))) + (contents (get-string-all port))) + (close-pipe port) + (call-with-input-string contents + (lambda (port) + (surrounding-sexp port (hunk-old-line-number hunk)))))) + +(define (new-sexp hunk) + "Using the diff information in HUNK return the modified S-expression +corresponding to the top-level definition containing the staged changes." + (call-with-input-file (hunk-file-name hunk) + (lambda (port) + (surrounding-sexp port + (hunk-new-line-number hunk))))) + +(define* (commit-message file-name old new #:optional (port (current-output-port))) + "Print ChangeLog commit message for changes between OLD and NEW." + (define (get-values expr field) + (match ((sxpath `(// ,field quasiquote *)) expr) + (() '()) + ((first . rest) + (map cadadr first)))) + (define (listify items) + (match items + ((one) one) + ((one two) + (string-append one " and " two)) + ((one two . more) + (string-append (string-join (drop-right items 1) ", ") + ", and " (first (take-right items 1)))))) + (define variable-name + (second old)) + (define version + (and=> ((sxpath '(// version *any*)) new) + first)) + (format port + "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%" + variable-name version file-name variable-name version) + (for-each (lambda (field) + (let ((old-values (get-values old field)) + (new-values (get-values new field))) + (or (equal? old-values new-values) + (let ((removed (lset-difference eq? old-values new-values)) + (added (lset-difference eq? new-values old-values))) + (format port + "[~a]: ~a~%" field + (match (list (map symbol->string removed) + (map symbol->string added)) + ((() added) + (format #f "Add ~a." + (listify added))) + ((removed ()) + (format #f "Remove ~a." + (listify removed))) + ((removed added) + (format #f "Remove ~a; add ~a." + (listify removed) + (listify added))))))))) + '(inputs propagated-inputs native-inputs))) + +(define (group-hunks-by-sexp hunks) + "Return a list of pairs associating all hunks with the S-expression they are +modifying." + (fold (lambda (sexp hunk acc) + (match acc + (((previous-sexp . hunks) . rest) + (if (equal? sexp previous-sexp) + (cons (cons previous-sexp + (cons hunk hunks)) + rest) + (cons (cons sexp (list hunk)) + acc))) + (_ + (cons (cons sexp (list hunk)) + acc)))) + '() + (map new-sexp hunks) + hunks)) + +(define (new+old+hunks hunks) + (map (match-lambda + ((new . hunks) + (cons* new (old-sexp (first hunks)) hunks))) + (group-hunks-by-sexp hunks))) + +(define (main . args) + (match (diff-info) + (() + (display "Nothing to be done." (current-error-port))) + (hunks + (for-each (match-lambda + ((new old . hunks) + (for-each (lambda (hunk) + (let ((port (open-pipe* OPEN_WRITE + "git" "apply" + "--cached" + "--unidiff-zero"))) + (hunk->patch hunk port) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "Cannot apply"))) + (sleep 1)) + hunks) + (commit-message (hunk-file-name (first hunks)) + old new + (current-output-port)) + (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) + (commit-message (hunk-file-name (first hunks)) + old new + port) + (sleep 1) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "Cannot commit"))))) + (new+old+hunks hunks))))) + +(main) diff --git a/etc/news.scm b/etc/news.scm index 6bf88ccb44..62ec68bab2 100644 --- a/etc/news.scm +++ b/etc/news.scm @@ -13,6 +13,80 @@ (channel-news (version 0) + (entry (commit "43badf261f4688c8a7a7a9004a4bff8acb205835") + (title (en "@command{guix pull} authenticates channels") + (de "@command{guix pull} authentifiziert Kanäle") + (fr "@command{guix pull} authentifie les canaux")) + (body + (en "The @command{guix pull} and @command{guix time-machine} commands +now authenticate the source code that they pull, unless the new +@option{--disable-authentication} option is passed. What this means is that +Guix ensures that each commit received is cryptographically signed by an +authorized developer. This protects you from attempts to tamper with the Guix +repository and from attempts to ship malicious code to users. + +This feature is currently limited to the @code{guix} channel but will soon be +available to third-party channel authors.") + (de "Die Befehle @command{guix pull} und @command{guix time-machine} +prüfen nun die Authentizität des heruntergeladenen Quellcodes, außer wenn die +neue Befehlszeilenoption @option{--disable-authentication} angegeben +wurde. Das bedeutet, Guix stellt sicher, dass jeder empfangene Commit durch +einen autorisierten Entwickler kryptografisch signiert wurde. Das schützt Sie +vor Versuchen, das Guix-Repository zu manipulieren oder bösartigen Code an die +Nutzer auszuliefern. + +Diese Funktionalität ist auf den @code{guix}-Kanal beschränkt, sie wird jedoch +bald auch Autoren dritter Kanäle zur Verfügung stehen.") + (fr "Les commandes @command{guix pull} et @command{guix time-machine} +authentifient dorénavant le code source qu'elles obtiennent, à moins que la +nouvelle option @option{--disable-authentication} soit utilisée. Cela +signifie que Guix s'assure que chaque soumission (@i{commit}) récupéré dispose +d'une signature cryptographique par un·e développeur·euse autorisé·e. Cela te +protège de tentatives de modifications du dépôt Guix et de tentatives de +livrer du code malintentionné. + +Cette fonctionnalité n'est actuellement disponible que pour le canal +@code{guix} mais le sera bientôt pour les canaux tiers."))) + + (entry (commit "c924e541390f9595d819edc33c19d979917c15ec") + (title (en "@command{guix repl} adds support for running Guile scripts") + (de "@command{guix repl} kann Guile-Skripte ausführen") + (fr "@command{guix repl} permet d'exécuter des scripts en langage Guile")) + (body + (en "The @command{guix repl} command can now be used to run +Guile scripts. Compared to just launching the @command{guile} command, +@command{guix repl} guarantees that all the Guix modules and all its +dependencies are available in the search path. Scripts are run like this: + +@example +guix repl -- my-script,scm --option1 --option2=option-arg arg1 arg2 +@end example + +Run @command{info \"(guix) Invoking guix repl\"} for more information.") + (de "Der Befehl @command{guix repl} kann jetzt zur Ausführung von +Guile-Skripten verwendet werden. Im Vergleich zum Befehl +@command{guile} garantiert @command{guix repl}, dass alle Guix-Module und +alle seine Abhängigkeiten im Suchpfad verfügbar sind. Skripte werden wie +folgt ausgeführt: + +@example +guix repl -- my-script,scm --option1 --option2 --option2=option-arg arg1 arg2 +@end example + +Weitere Informationen erhalten Sie mit +@command{info \"(guix.de) Aufruf von guix repl\"}.") + (fr "La commande @command{guix repl} peut maintenant être utilisée +pour exécuter des scripts en langage Guile. Par rapport au simple lancement +de la commande @command{guile}, @command{guix repl} garantit que tous les +modules Guix et toutes ses dépendances sont disponibles dans le chemin +de recherche. Les scripts sont exécutés comme ceci : + +@example +guix repl -- my-script,scm --option1 --option2=option-arg arg1 arg2 +@end example + +Exécutez @command{info \"(guix.fr) Invoquer guix repl\"} pour plus d'informations."))) + (entry (commit "b460ba7992a0b4af2ddb5927dcf062784539ef7b") (title (en "Add support to boot from a Btrfs subvolume") (de "Unterstützung für Systemstart von einem |