1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@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/>.
;;; 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 ui)
(guix git-download)
(guix upstream)
(guix utils)
(guix base32)
(guix build utils)
(guix scripts hash)
(gnu packages package-management)
(ice-9 match)
(ice-9 popen)
(ice-9 regex)
(ice-9 textual-ports)
(srfi srfi-1)
(srfi srfi-2)
(srfi srfi-26))
(define %top-srcdir
(string-append (current-source-directory) "/.."))
(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 (git-add-worktree directory commit)
"Create a new git worktree at DIRECTORY, detached on commit COMMIT."
(invoke "git" "worktree" "add" "--detach" directory commit))
(define (call-with-temporary-git-worktree commit proc)
"Execute PROC in the context of a temporary git worktree created from
COMMIT. PROC receives the temporary directory file name as an argument."
(call-with-temporary-directory
(lambda (tmp-directory)
(dynamic-wind
(lambda ()
#t)
(lambda ()
(git-add-worktree tmp-directory commit)
(proc tmp-directory))
(lambda ()
(invoke "git" "worktree" "remove" "--force" tmp-directory))))))
(define %savannah-guix-git-repo-push-url-regexp
"git.(savannah|sv).gnu.org:?/srv/git/guix.git \\(push\\)")
(define-syntax-rule (with-input-pipe-to-string prog arg ...)
(let* ((input-pipe (open-pipe* OPEN_READ prog arg ...))
(output (get-string-all input-pipe))
(exit-val (status:exit-val (close-pipe input-pipe))))
(unless (zero? exit-val)
(error (format #f "Command ~s exited with non-zero exit status: ~s"
(string-join (list prog arg ...)) exit-val)))
(string-trim-both output)))
(define (find-origin-remote)
"Find the name of the git remote with the Savannah Guix git repo URL."
(and-let* ((remotes (string-split (with-input-pipe-to-string
"git" "remote" "-v")
#\newline))
(origin-entry (find (cut string-match
%savannah-guix-git-repo-push-url-regexp
<>)
remotes)))
(first (string-split origin-entry #\tab))))
(define (commit-already-pushed? remote commit)
"True if COMMIT is found in the REMOTE repository."
(not (string-null? (with-input-pipe-to-string
"git" "branch" "-r" "--contains" commit
(string-append remote "/master")))))
(define (keep-source-in-store store source)
"Add SOURCE to the store under the name that the 'guix' package expects."
;; 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
#:select? (git-predicate 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
(string-append (getcwd) "/" root))
(info (G_ "source code kept in ~a (GC root: ~a)~%")
source root)))
(define (main . args)
(match args
((commit version)
(with-directory-excursion %top-srcdir
(or (getenv "GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT")
(let ((remote (find-origin-remote)))
(unless remote
(leave (G_ "Failed to find the origin git remote.~%")))
(commit-already-pushed? remote commit))
(leave (G_ "Commit ~a is not pushed upstream. Aborting.~%") commit))
(call-with-temporary-git-worktree commit
(lambda (tmp-directory)
(let* ((hash (nix-base32-string->bytevector
(string-trim-both
(with-output-to-string
(lambda ()
(guix-hash "-rx" tmp-directory))))))
(location (package-definition-location))
(old-hash (content-hash-value
(origin-hash (package-source guix)))))
(edit-expression location
(update-definition commit hash
#:old-hash old-hash
#:version version))
;; When GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT is set, the sources are
;; added to the store. This is used as part of 'make release'.
(when (getenv "GUIX_ALLOW_ME_TO_USE_PRIVATE_COMMIT")
(with-store store
(keep-source-in-store store tmp-directory))))))))
((commit)
;; Automatically deduce the version and revision numbers.
(main commit #f))))
(apply main (cdr (command-line)))
|