build-aux/update-guix-package.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
   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)))
 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)
 136            (add-indirect-root store root)
 137
 138            (format #t "source code for commit ~a: ~a (GC root: ~a)~%"
 139                    commit source root)))))
 140     ((commit)
 141      ;; Automatically deduce the version and revision numbers.
 142      (main commit #f))))
 143
 144 (apply main (cdr (command-line)))