build-aux/update-guix-package.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   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,
  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
 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
 116 COMMIT.  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 %savannah-guix-git-repo-push-url-regexp
 129   "git.(savannah|sv).gnu.org:?/srv/git/guix.git \\(push\\)")
 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))
 145              (origin-entry (find (cut string-match
 146                                       %savannah-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 \f
 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)))