Commit | Line | Data |
---|---|---|
94fa8d76 | 1 | ;;; GNU Guix --- Functional package management for GNU |
6eac835f | 2 | ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
94fa8d76 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; This scripts updates the definition of the 'guix' package in Guix for the | |
22 | ;;; current commit. It requires Git to be installed. | |
23 | ;;; | |
24 | ;;; Code: | |
25 | ||
26 | (use-modules (guix) | |
27 | (guix git-download) | |
28 | (guix upstream) | |
29 | (guix utils) | |
30 | (guix base32) | |
31 | (guix build utils) | |
32 | (gnu packages package-management) | |
33 | (ice-9 match)) | |
34 | ||
35 | (define %top-srcdir | |
36 | (string-append (current-source-directory) "/..")) | |
37 | ||
38 | (define version-controlled? | |
39 | (git-predicate %top-srcdir)) | |
40 | ||
41 | (define (package-definition-location) | |
42 | "Return the source properties of the definition of the 'guix' package." | |
43 | (call-with-input-file (location-file (package-location guix)) | |
44 | (lambda (port) | |
45 | (let loop () | |
46 | (match (read port) | |
47 | ((? eof-object?) | |
48 | (error "definition of 'guix' package could not be found" | |
49 | (port-filename port))) | |
50 | (('define-public 'guix value) | |
51 | (source-properties value)) | |
52 | (_ | |
53 | (loop))))))) | |
54 | ||
55 | (define* (update-definition commit hash | |
56 | #:key version old-hash) | |
57 | "Return a one-argument procedure that takes a string, the definition of the | |
58 | 'guix' package, and returns a string, the update definition for VERSION, | |
59 | COMMIT." | |
60 | (define (linear-offset str line column) | |
61 | ;; Return the offset in characters to reach LINE and COLUMN (both | |
62 | ;; zero-indexed) in STR. | |
63 | (call-with-input-string str | |
64 | (lambda (port) | |
65 | (let loop ((offset 0)) | |
66 | (cond ((and (= (port-column port) column) | |
67 | (= (port-line port) line)) | |
68 | offset) | |
69 | ((eof-object? (read-char port)) | |
70 | (error "line and column not reached!" | |
71 | str)) | |
72 | (else | |
73 | (loop (+ 1 offset)))))))) | |
74 | ||
75 | (define (update-hash str) | |
76 | ;; Replace OLD-HASH with HASH in STR. | |
77 | (string-replace-substring str | |
78 | (bytevector->nix-base32-string old-hash) | |
79 | (bytevector->nix-base32-string hash))) | |
80 | ||
81 | (lambda (str) | |
82 | (match (call-with-input-string str read) | |
83 | (('let (('version old-version) | |
84 | ('commit old-commit) | |
85 | ('revision old-revision)) | |
86 | defn) | |
87 | (let* ((location (source-properties defn)) | |
88 | (line (assq-ref location 'line)) | |
89 | (column 0) | |
90 | (offset (linear-offset str line column))) | |
91 | (string-append (format #f "(let ((version \"~a\") | |
92 | (commit \"~a\") | |
93 | (revision ~a))\n" | |
94 | (or version old-version) | |
95 | commit | |
96 | (if (and version | |
97 | (not (string=? version old-version))) | |
98 | 0 | |
99 | (+ 1 old-revision))) | |
100 | (string-drop (update-hash str) offset)))) | |
101 | (exp | |
102 | (error "'guix' package definition is not as expected" exp))))) | |
103 | ||
104 | \f | |
105 | (define (main . args) | |
106 | (match args | |
107 | ((commit version) | |
108 | (with-store store | |
109 | (let* ((source (add-to-store store | |
110 | "guix-checkout" ;dummy name | |
111 | #t "sha256" %top-srcdir | |
112 | #:select? version-controlled?)) | |
113 | (hash (query-path-hash store source)) | |
114 | (location (package-definition-location)) | |
115 | (old-hash (origin-sha256 (package-source guix)))) | |
116 | (edit-expression location | |
117 | (update-definition commit hash | |
118 | #:old-hash old-hash | |
119 | #:version version)) | |
120 | ||
121 | ;; Re-add SOURCE to the store, but this time under the real name used | |
122 | ;; in the 'origin'. This allows us to build the package without | |
123 | ;; having to make a real checkout; thus, it also works when working | |
124 | ;; on a private branch. | |
125 | (reload-module | |
126 | (resolve-module '(gnu packages package-management))) | |
aa1c3a00 LC |
127 | |
128 | (let* ((source (add-to-store store | |
129 | (origin-file-name (package-source guix)) | |
130 | #t "sha256" source)) | |
131 | (root (store-path-package-name source))) | |
132 | ||
133 | ;; Add an indirect GC root for SOURCE in the current directory. | |
134 | (false-if-exception (delete-file root)) | |
135 | (symlink source root) | |
6eac835f LC |
136 | (add-indirect-root store |
137 | (string-append (getcwd) "/" root)) | |
aa1c3a00 LC |
138 | |
139 | (format #t "source code for commit ~a: ~a (GC root: ~a)~%" | |
140 | commit source root))))) | |
94fa8d76 LC |
141 | ((commit) |
142 | ;; Automatically deduce the version and revision numbers. | |
143 | (main commit #f)))) | |
144 | ||
145 | (apply main (cdr (command-line))) |