projects/guix·blob master · refs

215 lines · 8.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017-2018, 2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2020, 2025 Maxim Cournoyer <[email protected]>
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)
28 (guix ui)
29 (guix git-download)
30 (guix upstream)
31 (guix utils)
32 (guix base32)
33 (guix build utils)
34 (guix scripts hash)
35 (gnu packages package-management)
36 (ice-9 match)
37 (ice-9 popen)
38 (ice-9 regex)
39 (ice-9 textual-ports)
40 (srfi srfi-1)
41 (srfi srfi-2)
42 (srfi srfi-26))
43
44(define %top-srcdir
45 (string-append (current-source-directory) "/.."))
46
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,
65COMMIT."
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
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
114(define (call-with-temporary-git-worktree commit proc)
115 "Execute PROC in the context of a temporary git worktree created from
116COMMIT. PROC receives the temporary directory file name as an argument."
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)
124 (proc tmp-directory))
125 (lambda ()
126 (invoke "git" "worktree" "remove" "--force" tmp-directory))))))
127
128(define %guix-git-repo-push-url-regexp
129 "(git.guix.gnu.org|codeberg.org/guix|[email protected]:guix)/guix(.git)? \\(push\\)")
130
131(define (with-input-pipe-to-string prog . args)
132 (let* ((input-pipe (apply open-pipe* OPEN_READ prog args))
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 (cons prog args)) exit-val)))
138 (string-trim-both output)))
139
140(define (find-origin-remote)
141 "Find the name of the git remote with the Guix git repo URL."
142 (and-let* ((remotes (string-split (with-input-pipe-to-string
143 "git" "remote" "-v")
144 #\newline))
145 (origin-entry (find (cut string-match
146 %guix-git-repo-push-url-regexp
147 <>)
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
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
181
182(define (main . args)
183 (match args
184 ((commit version)
185 (with-directory-excursion %top-srcdir
186 (or (getenv "GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT")
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))
191 (leave (G_ "Commit ~a is not pushed upstream. Aborting.~%") commit))
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))))))))
211 ((commit)
212 ;; Automatically deduce the version and revision numbers.
213 (main commit #f))))
214
215(apply main (cdr (command-line)))