Commit | Line | Data |
---|---|---|
94fa8d76 | 1 | ;;; GNU Guix --- Functional package management for GNU |
6eac835f | 2 | ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
5800d2aa | 3 | ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> |
94fa8d76 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;; Commentary: | |
21 | ;;; | |
22 | ;;; This scripts updates the definition of the 'guix' package in Guix for the | |
23 | ;;; current commit. It requires Git to be installed. | |
24 | ;;; | |
25 | ;;; Code: | |
26 | ||
27 | (use-modules (guix) | |
5800d2aa | 28 | (guix ui) |
94fa8d76 LC |
29 | (guix git-download) |
30 | (guix upstream) | |
31 | (guix utils) | |
32 | (guix base32) | |
33 | (guix build utils) | |
5800d2aa | 34 | (guix scripts hash) |
94fa8d76 | 35 | (gnu packages package-management) |
5800d2aa MC |
36 | (ice-9 match) |
37 | (ice-9 popen) | |
13a3b9c7 | 38 | (ice-9 regex) |
5800d2aa MC |
39 | (ice-9 textual-ports) |
40 | (srfi srfi-1) | |
41 | (srfi srfi-2) | |
42 | (srfi srfi-26)) | |
94fa8d76 LC |
43 | |
44 | (define %top-srcdir | |
45 | (string-append (current-source-directory) "/..")) | |
46 | ||
94fa8d76 LC |
47 | (define (package-definition-location) |
48 | "Return the source properties of the definition of the 'guix' package." | |
49 | (call-with-input-file (location-file (package-location guix)) | |
50 | (lambda (port) | |
51 | (let loop () | |
52 | (match (read port) | |
53 | ((? eof-object?) | |
54 | (error "definition of 'guix' package could not be found" | |
55 | (port-filename port))) | |
56 | (('define-public 'guix value) | |
57 | (source-properties value)) | |
58 | (_ | |
59 | (loop))))))) | |
60 | ||
61 | (define* (update-definition commit hash | |
62 | #:key version old-hash) | |
63 | "Return a one-argument procedure that takes a string, the definition of the | |
64 | 'guix' package, and returns a string, the update definition for VERSION, | |
65 | COMMIT." | |
66 | (define (linear-offset str line column) | |
67 | ;; Return the offset in characters to reach LINE and COLUMN (both | |
68 | ;; zero-indexed) in STR. | |
69 | (call-with-input-string str | |
70 | (lambda (port) | |
71 | (let loop ((offset 0)) | |
72 | (cond ((and (= (port-column port) column) | |
73 | (= (port-line port) line)) | |
74 | offset) | |
75 | ((eof-object? (read-char port)) | |
76 | (error "line and column not reached!" | |
77 | str)) | |
78 | (else | |
79 | (loop (+ 1 offset)))))))) | |
80 | ||
81 | (define (update-hash str) | |
82 | ;; Replace OLD-HASH with HASH in STR. | |
83 | (string-replace-substring str | |
84 | (bytevector->nix-base32-string old-hash) | |
85 | (bytevector->nix-base32-string hash))) | |
86 | ||
87 | (lambda (str) | |
88 | (match (call-with-input-string str read) | |
89 | (('let (('version old-version) | |
90 | ('commit old-commit) | |
91 | ('revision old-revision)) | |
92 | defn) | |
93 | (let* ((location (source-properties defn)) | |
94 | (line (assq-ref location 'line)) | |
95 | (column 0) | |
96 | (offset (linear-offset str line column))) | |
97 | (string-append (format #f "(let ((version \"~a\") | |
98 | (commit \"~a\") | |
99 | (revision ~a))\n" | |
100 | (or version old-version) | |
101 | commit | |
102 | (if (and version | |
103 | (not (string=? version old-version))) | |
104 | 0 | |
105 | (+ 1 old-revision))) | |
106 | (string-drop (update-hash str) offset)))) | |
107 | (exp | |
108 | (error "'guix' package definition is not as expected" exp))))) | |
109 | ||
5800d2aa MC |
110 | (define (git-add-worktree directory commit) |
111 | "Create a new git worktree at DIRECTORY, detached on commit COMMIT." | |
112 | (invoke "git" "worktree" "add" "--detach" directory commit)) | |
113 | ||
3de898b4 MC |
114 | (define (call-with-temporary-git-worktree commit proc) |
115 | "Execute PROC in the context of a temporary git worktree created from | |
116 | COMMIT. PROC receives the temporary directory file name as an argument." | |
5800d2aa MC |
117 | (call-with-temporary-directory |
118 | (lambda (tmp-directory) | |
119 | (dynamic-wind | |
120 | (lambda () | |
121 | #t) | |
122 | (lambda () | |
123 | (git-add-worktree tmp-directory commit) | |
3de898b4 | 124 | (proc tmp-directory)) |
5800d2aa MC |
125 | (lambda () |
126 | (invoke "git" "worktree" "remove" "--force" tmp-directory)))))) | |
127 | ||
13a3b9c7 | 128 | (define %savannah-guix-git-repo-push-url-regexp |
3de898b4 | 129 | "git.(savannah|sv).gnu.org:?/srv/git/guix.git \\(push\\)") |
5800d2aa MC |
130 | |
131 | (define-syntax-rule (with-input-pipe-to-string prog arg ...) | |
132 | (let* ((input-pipe (open-pipe* OPEN_READ prog arg ...)) | |
133 | (output (get-string-all input-pipe)) | |
134 | (exit-val (status:exit-val (close-pipe input-pipe)))) | |
135 | (unless (zero? exit-val) | |
136 | (error (format #f "Command ~s exited with non-zero exit status: ~s" | |
137 | (string-join (list prog arg ...)) exit-val))) | |
138 | (string-trim-both output))) | |
139 | ||
140 | (define (find-origin-remote) | |
141 | "Find the name of the git remote with the Savannah Guix git repo URL." | |
142 | (and-let* ((remotes (string-split (with-input-pipe-to-string | |
143 | "git" "remote" "-v") | |
144 | #\newline)) | |
13a3b9c7 MC |
145 | (origin-entry (find (cut string-match |
146 | %savannah-guix-git-repo-push-url-regexp | |
147 | <>) | |
5800d2aa MC |
148 | remotes))) |
149 | (first (string-split origin-entry #\tab)))) | |
150 | ||
151 | (define (commit-already-pushed? remote commit) | |
152 | "True if COMMIT is found in the REMOTE repository." | |
153 | (not (string-null? (with-input-pipe-to-string | |
154 | "git" "branch" "-r" "--contains" commit | |
155 | (string-append remote "/master"))))) | |
156 | ||
3de898b4 MC |
157 | (define (keep-source-in-store store source) |
158 | "Add SOURCE to the store under the name that the 'guix' package expects." | |
159 | ||
160 | ;; Add SOURCE to the store, but this time under the real name used in the | |
161 | ;; 'origin'. This allows us to build the package without having to make a | |
162 | ;; real checkout; thus, it also works when working on a private branch. | |
163 | (reload-module | |
164 | (resolve-module '(gnu packages package-management))) | |
165 | ||
166 | (let* ((source (add-to-store store | |
167 | (origin-file-name (package-source guix)) | |
168 | #t "sha256" source | |
169 | #:select? (git-predicate source))) | |
170 | (root (store-path-package-name source))) | |
171 | ||
172 | ;; Add an indirect GC root for SOURCE in the current directory. | |
173 | (false-if-exception (delete-file root)) | |
174 | (symlink source root) | |
175 | (add-indirect-root store | |
176 | (string-append (getcwd) "/" root)) | |
177 | ||
178 | (info (G_ "source code kept in ~a (GC root: ~a)~%") | |
179 | source root))) | |
180 | ||
94fa8d76 LC |
181 | \f |
182 | (define (main . args) | |
183 | (match args | |
184 | ((commit version) | |
5800d2aa MC |
185 | (with-directory-excursion %top-srcdir |
186 | (or (getenv "GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT") | |
3de898b4 MC |
187 | (let ((remote (find-origin-remote))) |
188 | (unless remote | |
189 | (leave (G_ "Failed to find the origin git remote.~%"))) | |
190 | (commit-already-pushed? remote commit)) | |
5800d2aa | 191 | (leave (G_ "Commit ~a is not pushed upstream. Aborting.~%") commit)) |
3de898b4 MC |
192 | (call-with-temporary-git-worktree commit |
193 | (lambda (tmp-directory) | |
194 | (let* ((hash (nix-base32-string->bytevector | |
195 | (string-trim-both | |
196 | (with-output-to-string | |
197 | (lambda () | |
198 | (guix-hash "-rx" tmp-directory)))))) | |
199 | (location (package-definition-location)) | |
200 | (old-hash (content-hash-value | |
201 | (origin-hash (package-source guix))))) | |
202 | (edit-expression location | |
203 | (update-definition commit hash | |
204 | #:old-hash old-hash | |
205 | #:version version)) | |
206 | ;; When GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT is set, the sources are | |
207 | ;; added to the store. This is used as part of 'make release'. | |
208 | (when (getenv "GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT") | |
209 | (with-store store | |
210 | (keep-source-in-store store tmp-directory)))))))) | |
94fa8d76 LC |
211 | ((commit) |
212 | ;; Automatically deduce the version and revision numbers. | |
213 | (main commit #f)))) | |
214 | ||
215 | (apply main (cdr (command-line))) |