You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

146 lines
5.5 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017, 2018 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. ;;; Commentary:
  19. ;;;
  20. ;;; This scripts updates the definition of the 'guix' package in Guix for the
  21. ;;; current commit. It requires Git to be installed.
  22. ;;;
  23. ;;; Code:
  24. (use-modules (guix)
  25. (guix git-download)
  26. (guix upstream)
  27. (guix utils)
  28. (guix base32)
  29. (guix build utils)
  30. (gnu packages package-management)
  31. (ice-9 match))
  32. (define %top-srcdir
  33. (string-append (current-source-directory) "/.."))
  34. (define version-controlled?
  35. (git-predicate %top-srcdir))
  36. (define (package-definition-location)
  37. "Return the source properties of the definition of the 'guix' package."
  38. (call-with-input-file (location-file (package-location guix))
  39. (lambda (port)
  40. (let loop ()
  41. (match (read port)
  42. ((? eof-object?)
  43. (error "definition of 'guix' package could not be found"
  44. (port-filename port)))
  45. (('define-public 'guix value)
  46. (source-properties value))
  47. (_
  48. (loop)))))))
  49. (define* (update-definition commit hash
  50. #:key version old-hash)
  51. "Return a one-argument procedure that takes a string, the definition of the
  52. 'guix' package, and returns a string, the update definition for VERSION,
  53. COMMIT."
  54. (define (linear-offset str line column)
  55. ;; Return the offset in characters to reach LINE and COLUMN (both
  56. ;; zero-indexed) in STR.
  57. (call-with-input-string str
  58. (lambda (port)
  59. (let loop ((offset 0))
  60. (cond ((and (= (port-column port) column)
  61. (= (port-line port) line))
  62. offset)
  63. ((eof-object? (read-char port))
  64. (error "line and column not reached!"
  65. str))
  66. (else
  67. (loop (+ 1 offset))))))))
  68. (define (update-hash str)
  69. ;; Replace OLD-HASH with HASH in STR.
  70. (string-replace-substring str
  71. (bytevector->nix-base32-string old-hash)
  72. (bytevector->nix-base32-string hash)))
  73. (lambda (str)
  74. (match (call-with-input-string str read)
  75. (('let (('version old-version)
  76. ('commit old-commit)
  77. ('revision old-revision))
  78. defn)
  79. (let* ((location (source-properties defn))
  80. (line (assq-ref location 'line))
  81. (column 0)
  82. (offset (linear-offset str line column)))
  83. (string-append (format #f "(let ((version \"~a\")
  84. (commit \"~a\")
  85. (revision ~a))\n"
  86. (or version old-version)
  87. commit
  88. (if (and version
  89. (not (string=? version old-version)))
  90. 0
  91. (+ 1 old-revision)))
  92. (string-drop (update-hash str) offset))))
  93. (exp
  94. (error "'guix' package definition is not as expected" exp)))))
  95. (define (main . args)
  96. (match args
  97. ((commit version)
  98. (with-store store
  99. (let* ((source (add-to-store store
  100. "guix-checkout" ;dummy name
  101. #t "sha256" %top-srcdir
  102. #:select? version-controlled?))
  103. (hash (query-path-hash store source))
  104. (location (package-definition-location))
  105. (old-hash (origin-sha256 (package-source guix))))
  106. (edit-expression location
  107. (update-definition commit hash
  108. #:old-hash old-hash
  109. #:version version))
  110. ;; Re-add SOURCE to the store, but this time under the real name used
  111. ;; in the 'origin'. This allows us to build the package without
  112. ;; having to make a real checkout; thus, it also works when working
  113. ;; on a private branch.
  114. (reload-module
  115. (resolve-module '(gnu packages package-management)))
  116. (let* ((source (add-to-store store
  117. (origin-file-name (package-source guix))
  118. #t "sha256" source))
  119. (root (store-path-package-name source)))
  120. ;; Add an indirect GC root for SOURCE in the current directory.
  121. (false-if-exception (delete-file root))
  122. (symlink source root)
  123. (add-indirect-root store
  124. (string-append (getcwd) "/" root))
  125. (format #t "source code for commit ~a: ~a (GC root: ~a)~%"
  126. commit source root)))))
  127. ((commit)
  128. ;; Automatically deduce the version and revision numbers.
  129. (main commit #f))))
  130. (apply main (cdr (command-line)))