blob: 83f6eca6bb9523f2fbcdc954dcc1d25bdcb05d5c (
plain)
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
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018 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
(string-append (getcwd) "/" 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)))
|