2013-01-06 00:47:50 +01:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2013-01-08 22:46:12 +01:00
|
|
|
|
;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
2013-03-28 22:40:41 +01:00
|
|
|
|
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
2012-12-05 00:02:22 +01:00
|
|
|
|
;;;
|
2013-01-06 00:47:50 +01:00
|
|
|
|
;;; This file is part of GNU Guix.
|
2012-12-05 00:02:22 +01:00
|
|
|
|
;;;
|
2013-01-06 00:47:50 +01:00
|
|
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
2012-12-05 00:02:22 +01:00
|
|
|
|
;;; 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.
|
|
|
|
|
;;;
|
2013-01-06 00:47:50 +01:00
|
|
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
2012-12-05 00:02:22 +01:00
|
|
|
|
;;; 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
|
2013-01-06 00:47:50 +01:00
|
|
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
2012-12-05 00:02:22 +01:00
|
|
|
|
|
|
|
|
|
(define-module (guix gnu-maintenance)
|
|
|
|
|
#:use-module (web uri)
|
|
|
|
|
#:use-module (web client)
|
|
|
|
|
#:use-module (web response)
|
|
|
|
|
#:use-module (ice-9 regex)
|
2013-01-08 22:46:12 +01:00
|
|
|
|
#:use-module (ice-9 match)
|
2012-12-05 00:02:22 +01:00
|
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
|
#:use-module (srfi srfi-11)
|
|
|
|
|
#:use-module (srfi srfi-26)
|
2013-01-08 22:46:12 +01:00
|
|
|
|
#:use-module (system foreign)
|
2013-04-25 22:06:48 +02:00
|
|
|
|
#:use-module (guix web)
|
2013-01-08 22:46:12 +01:00
|
|
|
|
#:use-module (guix ftp-client)
|
2013-04-21 10:08:40 +02:00
|
|
|
|
#:use-module (guix ui)
|
2013-02-12 18:02:15 +01:00
|
|
|
|
#:use-module (guix utils)
|
2013-05-12 15:46:16 +02:00
|
|
|
|
#:use-module (guix records)
|
2013-03-05 20:30:27 +01:00
|
|
|
|
#:use-module (guix packages)
|
2013-04-24 23:48:36 +02:00
|
|
|
|
#:use-module ((guix download) #:select (download-to-store))
|
|
|
|
|
#:use-module (guix gnupg)
|
|
|
|
|
#:use-module (rnrs io ports)
|
|
|
|
|
#:use-module (guix base32)
|
|
|
|
|
#:use-module ((guix build utils)
|
|
|
|
|
#:select (substitute))
|
2013-03-28 22:40:41 +01:00
|
|
|
|
#:export (gnu-package-name
|
|
|
|
|
gnu-package-mundane-name
|
|
|
|
|
gnu-package-copyright-holder
|
|
|
|
|
gnu-package-savannah
|
|
|
|
|
gnu-package-fsd
|
|
|
|
|
gnu-package-language
|
|
|
|
|
gnu-package-logo
|
|
|
|
|
gnu-package-doc-category
|
|
|
|
|
gnu-package-doc-summary
|
|
|
|
|
gnu-package-doc-urls
|
|
|
|
|
gnu-package-download-url
|
|
|
|
|
|
|
|
|
|
official-gnu-packages
|
|
|
|
|
find-packages
|
2013-03-05 20:30:27 +01:00
|
|
|
|
gnu-package?
|
2013-03-28 22:40:41 +01:00
|
|
|
|
|
2013-01-08 22:46:12 +01:00
|
|
|
|
releases
|
|
|
|
|
latest-release
|
2013-04-24 23:48:36 +02:00
|
|
|
|
gnu-package-name->name+version
|
|
|
|
|
package-update-path
|
|
|
|
|
package-update
|
|
|
|
|
update-package-source))
|
2013-01-08 22:46:12 +01:00
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
;;;
|
|
|
|
|
;;; Code for dealing with the maintenance of GNU packages, such as
|
|
|
|
|
;;; auto-updates.
|
|
|
|
|
;;;
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; List of GNU packages.
|
|
|
|
|
;;;
|
2012-12-05 00:02:22 +01:00
|
|
|
|
|
|
|
|
|
(define %package-list-url
|
2013-04-25 22:06:48 +02:00
|
|
|
|
(string->uri
|
|
|
|
|
(string-append "http://cvs.savannah.gnu.org/"
|
|
|
|
|
"viewvc/*checkout*/gnumaint/"
|
|
|
|
|
"gnupackages.txt?root=womb")))
|
2012-12-05 00:02:22 +01:00
|
|
|
|
|
2013-03-28 22:40:41 +01:00
|
|
|
|
(define-record-type* <gnu-package-descriptor>
|
|
|
|
|
gnu-package-descriptor
|
|
|
|
|
make-gnu-package-descriptor
|
|
|
|
|
|
|
|
|
|
gnu-package-descriptor?
|
|
|
|
|
|
|
|
|
|
(name gnu-package-name)
|
|
|
|
|
(mundane-name gnu-package-mundane-name)
|
|
|
|
|
(copyright-holder gnu-package-copyright-holder)
|
|
|
|
|
(savannah gnu-package-savannah)
|
|
|
|
|
(fsd gnu-package-fsd)
|
2013-07-10 18:08:09 +02:00
|
|
|
|
(language gnu-package-language) ; list of strings
|
2013-03-28 22:40:41 +01:00
|
|
|
|
(logo gnu-package-logo)
|
|
|
|
|
(doc-category gnu-package-doc-category)
|
|
|
|
|
(doc-summary gnu-package-doc-summary)
|
2013-07-10 18:08:09 +02:00
|
|
|
|
(doc-urls gnu-package-doc-urls) ; list of strings
|
2013-03-28 22:40:41 +01:00
|
|
|
|
(download-url gnu-package-download-url))
|
|
|
|
|
|
2012-12-05 00:02:22 +01:00
|
|
|
|
(define (official-gnu-packages)
|
2013-03-28 22:40:41 +01:00
|
|
|
|
"Return a list of records, which are GNU packages."
|
2013-07-10 18:08:09 +02:00
|
|
|
|
(define (group-package-fields port)
|
2013-03-28 22:40:41 +01:00
|
|
|
|
;; Return a list of alists. Each alist contains fields of a GNU
|
|
|
|
|
;; package.
|
2013-07-10 18:08:09 +02:00
|
|
|
|
(let loop ((alist (recutils->alist port))
|
|
|
|
|
(result '()))
|
|
|
|
|
(if (null? alist)
|
|
|
|
|
result
|
|
|
|
|
(loop (recutils->alist port)
|
|
|
|
|
(cons alist result)))))
|
2013-03-28 22:40:41 +01:00
|
|
|
|
|
|
|
|
|
(reverse
|
|
|
|
|
(map (lambda (alist)
|
|
|
|
|
(alist->record alist
|
|
|
|
|
make-gnu-package-descriptor
|
|
|
|
|
(list "package" "mundane-name" "copyright-holder"
|
|
|
|
|
"savannah" "fsd" "language" "logo"
|
2013-07-10 18:08:09 +02:00
|
|
|
|
"doc-category" "doc-summary" "doc-url"
|
|
|
|
|
"download-url")
|
|
|
|
|
'("doc-url" "language")))
|
|
|
|
|
(group-package-fields (http-fetch %package-list-url #:text? #t)))))
|
2012-12-05 00:02:22 +01:00
|
|
|
|
|
2013-03-28 22:40:41 +01:00
|
|
|
|
(define (find-packages regexp)
|
|
|
|
|
"Find GNU packages which satisfy REGEXP."
|
|
|
|
|
(let ((name-rx (make-regexp regexp)))
|
|
|
|
|
(filter (lambda (package)
|
|
|
|
|
(false-if-exception
|
|
|
|
|
(regexp-exec name-rx (gnu-package-name package))))
|
|
|
|
|
(official-gnu-packages))))
|
2013-03-05 20:30:27 +01:00
|
|
|
|
|
|
|
|
|
(define gnu-package?
|
|
|
|
|
(memoize
|
2013-04-24 23:49:05 +02:00
|
|
|
|
(let ((official-gnu-packages (memoize official-gnu-packages)))
|
|
|
|
|
(lambda (package)
|
|
|
|
|
"Return true if PACKAGE is a GNU package. This procedure may access the
|
2013-03-05 20:30:27 +01:00
|
|
|
|
network to check in GNU's database."
|
2013-04-24 23:49:05 +02:00
|
|
|
|
;; TODO: Find a way to determine that a package is non-GNU without going
|
|
|
|
|
;; through the network.
|
|
|
|
|
(let ((url (and=> (package-source package) origin-uri))
|
|
|
|
|
(name (package-name package)))
|
|
|
|
|
(or (and (string? url) (string-prefix? "mirror://gnu" url))
|
|
|
|
|
(and (member name (map gnu-package-name (official-gnu-packages)))
|
|
|
|
|
#t)))))))
|
2013-03-05 20:30:27 +01:00
|
|
|
|
|
2013-01-08 22:46:12 +01:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Latest release.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (ftp-server/directory project)
|
|
|
|
|
"Return the FTP server and directory where PROJECT's tarball are
|
|
|
|
|
stored."
|
|
|
|
|
(define quirks
|
|
|
|
|
'(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp")
|
|
|
|
|
("ucommon" "ftp.gnu.org" "/gnu/commoncpp")
|
|
|
|
|
("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp")
|
|
|
|
|
("libosip2" "ftp.gnu.org" "/gnu/osip")
|
|
|
|
|
("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt")
|
|
|
|
|
("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
|
|
|
|
|
("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan")
|
|
|
|
|
("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg")
|
|
|
|
|
("freefont-ttf" "ftp.gnu.org" "/gnu/freefont")
|
|
|
|
|
("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript")
|
|
|
|
|
("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
|
|
|
|
|
("icecat" "ftp.gnu.org" "/gnu/gnuzilla")
|
|
|
|
|
("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
|
2013-04-24 23:48:36 +02:00
|
|
|
|
("glib" "ftp.gnome.org" "/pub/gnome/sources/glib")
|
2013-05-10 01:15:04 +02:00
|
|
|
|
("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls")
|
2013-01-08 22:46:12 +01:00
|
|
|
|
("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz")))
|
|
|
|
|
|
|
|
|
|
(match (assoc project quirks)
|
|
|
|
|
((_ server directory)
|
|
|
|
|
(values server directory))
|
|
|
|
|
(_
|
|
|
|
|
(values "ftp.gnu.org" (string-append "/gnu/" project)))))
|
|
|
|
|
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(define (sans-extension tarball)
|
|
|
|
|
"Return TARBALL without its .tar.* extension."
|
|
|
|
|
(let ((end (string-contains tarball ".tar")))
|
|
|
|
|
(substring tarball 0 end)))
|
2013-01-08 22:46:12 +01:00
|
|
|
|
|
2013-04-24 23:37:14 +02:00
|
|
|
|
(define %tarball-rx
|
|
|
|
|
(make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.tar\\."))
|
|
|
|
|
|
|
|
|
|
(define %alpha-tarball-rx
|
|
|
|
|
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
|
|
|
|
|
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(define (release-file project file)
|
|
|
|
|
"Return #f if FILE is not a release tarball of PROJECT, otherwise return
|
|
|
|
|
PACKAGE-VERSION."
|
|
|
|
|
(and (not (string-suffix? ".sig" file))
|
2013-04-24 23:37:14 +02:00
|
|
|
|
(and=> (regexp-exec %tarball-rx file)
|
|
|
|
|
(lambda (match)
|
|
|
|
|
;; Filter out unrelated files, like `guile-www-1.1.1'.
|
|
|
|
|
(equal? project (match:substring match 1))))
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(not (regexp-exec %alpha-tarball-rx file))
|
|
|
|
|
(let ((s (sans-extension file)))
|
|
|
|
|
(and (regexp-exec %package-name-rx s) s))))
|
2013-03-05 22:31:19 +01:00
|
|
|
|
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(define (releases project)
|
|
|
|
|
"Return the list of releases of PROJECT as a list of release name/directory
|
|
|
|
|
pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
|
|
|
|
|
;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
|
2013-01-08 22:46:12 +01:00
|
|
|
|
(let-values (((server directory) (ftp-server/directory project)))
|
|
|
|
|
(define conn (ftp-open server))
|
|
|
|
|
|
|
|
|
|
(let loop ((directories (list directory))
|
|
|
|
|
(result '()))
|
2013-03-05 22:31:19 +01:00
|
|
|
|
(match directories
|
|
|
|
|
(()
|
|
|
|
|
(ftp-close conn)
|
|
|
|
|
result)
|
|
|
|
|
((directory rest ...)
|
|
|
|
|
(let* ((files (ftp-list conn directory))
|
|
|
|
|
(subdirs (filter-map (match-lambda
|
|
|
|
|
((name 'directory . _) name)
|
|
|
|
|
(_ #f))
|
|
|
|
|
files)))
|
|
|
|
|
(loop (append (map (cut string-append directory "/" <>)
|
|
|
|
|
subdirs)
|
|
|
|
|
rest)
|
|
|
|
|
(append
|
|
|
|
|
;; Filter out signatures, deltas, and files which
|
|
|
|
|
;; are potentially not releases of PROJECT--e.g.,
|
|
|
|
|
;; in /gnu/guile, filter out guile-oops and
|
|
|
|
|
;; guile-www; in mit-scheme, filter out binaries.
|
|
|
|
|
(filter-map (match-lambda
|
|
|
|
|
((file 'file . _)
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(and=> (release-file project file)
|
2013-03-05 22:31:19 +01:00
|
|
|
|
(cut cons <> directory)))
|
|
|
|
|
(_ #f))
|
|
|
|
|
files)
|
|
|
|
|
result))))))))
|
2013-01-08 22:46:12 +01:00
|
|
|
|
|
|
|
|
|
(define (latest-release project)
|
|
|
|
|
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(define (latest a b)
|
|
|
|
|
(if (version>? a b) a b))
|
|
|
|
|
|
|
|
|
|
(define contains-digit?
|
|
|
|
|
(cut string-any char-set:digit <>))
|
|
|
|
|
|
|
|
|
|
(let-values (((server directory) (ftp-server/directory project)))
|
|
|
|
|
(define conn (ftp-open server))
|
|
|
|
|
|
|
|
|
|
(let loop ((directory directory))
|
|
|
|
|
(let* ((entries (ftp-list conn directory))
|
2013-04-27 16:26:48 +02:00
|
|
|
|
|
|
|
|
|
;; Filter out sub-directories that do not contain digits---e.g.,
|
|
|
|
|
;; /gnuzilla/lang and /gnupg/patches.
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(subdirs (filter-map (match-lambda
|
2013-04-27 16:26:48 +02:00
|
|
|
|
(((? contains-digit? dir) 'directory . _)
|
|
|
|
|
dir)
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(_ #f))
|
|
|
|
|
entries)))
|
|
|
|
|
(match subdirs
|
|
|
|
|
(()
|
|
|
|
|
;; No sub-directories, so assume that tarballs are here.
|
|
|
|
|
(let ((files (filter-map (match-lambda
|
|
|
|
|
((file 'file . _)
|
|
|
|
|
(release-file project file))
|
|
|
|
|
(_ #f))
|
|
|
|
|
entries)))
|
|
|
|
|
(and=> (reduce latest #f files)
|
|
|
|
|
(cut cons <> directory))))
|
|
|
|
|
((subdirs ...)
|
|
|
|
|
;; Assume that SUBDIRS correspond to versions, and jump into the
|
2013-04-27 16:26:48 +02:00
|
|
|
|
;; one with the highest version number.
|
|
|
|
|
(let ((target (reduce latest #f subdirs)))
|
2013-04-24 23:17:31 +02:00
|
|
|
|
(and target
|
|
|
|
|
(loop (string-append directory "/" target))))))))))
|
2013-01-08 22:46:12 +01:00
|
|
|
|
|
|
|
|
|
(define %package-name-rx
|
|
|
|
|
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
|
|
|
|
|
;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
|
|
|
|
|
(make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
|
|
|
|
|
|
|
|
|
|
(define (gnu-package-name->name+version name+version)
|
|
|
|
|
"Return the package name and version number extracted from NAME+VERSION."
|
|
|
|
|
(let ((match (regexp-exec %package-name-rx name+version)))
|
|
|
|
|
(if (not match)
|
|
|
|
|
(values name+version #f)
|
|
|
|
|
(values (match:substring match 1) (match:substring match 2)))))
|
|
|
|
|
|
2013-04-24 23:48:36 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Auto-update.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (package-update-path package)
|
|
|
|
|
"Return an update path for PACKAGE, or #f if no update is needed."
|
|
|
|
|
(and (gnu-package? package)
|
|
|
|
|
(match (latest-release (package-name package))
|
|
|
|
|
((name+version . directory)
|
|
|
|
|
(let-values (((_ new-version)
|
|
|
|
|
(package-name->name+version name+version)))
|
|
|
|
|
(and (version>? name+version (package-full-name package))
|
|
|
|
|
`(,new-version . ,directory))))
|
|
|
|
|
(_ #f))))
|
|
|
|
|
|
|
|
|
|
(define* (download-tarball store project directory version
|
2013-06-10 09:46:13 +02:00
|
|
|
|
#:key (archive-type "gz")
|
|
|
|
|
(key-download 'interactive))
|
2013-04-24 23:48:36 +02:00
|
|
|
|
"Download PROJECT's tarball over FTP and check its OpenPGP signature. On
|
2013-06-10 09:46:13 +02:00
|
|
|
|
success, return the tarball file name. KEY-DOWNLOAD specifies a download
|
|
|
|
|
policy for missing OpenPGP keys; allowed values: 'interactive' (default),
|
|
|
|
|
'always', and 'never'."
|
2013-04-24 23:48:36 +02:00
|
|
|
|
(let* ((server (ftp-server/directory project))
|
|
|
|
|
(base (string-append project "-" version ".tar." archive-type))
|
|
|
|
|
(url (string-append "ftp://" server "/" directory "/" base))
|
|
|
|
|
(sig-url (string-append url ".sig"))
|
|
|
|
|
(tarball (download-to-store store url))
|
|
|
|
|
(sig (download-to-store store sig-url)))
|
2013-06-10 09:46:13 +02:00
|
|
|
|
(let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
|
2013-04-24 23:48:36 +02:00
|
|
|
|
(if ret
|
|
|
|
|
tarball
|
|
|
|
|
(begin
|
2013-04-25 23:07:24 +02:00
|
|
|
|
(warning (_ "signature verification failed for `~a'~%")
|
2013-04-24 23:48:36 +02:00
|
|
|
|
base)
|
2013-04-25 23:07:24 +02:00
|
|
|
|
(warning (_ "(could be because the public key is not in your keyring)~%"))
|
2013-04-24 23:48:36 +02:00
|
|
|
|
#f)))))
|
|
|
|
|
|
2013-06-10 09:46:13 +02:00
|
|
|
|
(define* (package-update store package #:key (key-download 'interactive))
|
2013-04-24 23:48:36 +02:00
|
|
|
|
"Return the new version and the file name of the new version tarball for
|
2013-06-10 09:46:13 +02:00
|
|
|
|
PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
|
|
|
|
|
download policy for missing OpenPGP keys; allowed values: 'always', 'never',
|
|
|
|
|
and 'interactive' (default)."
|
2013-04-24 23:48:36 +02:00
|
|
|
|
(match (package-update-path package)
|
|
|
|
|
((version . directory)
|
|
|
|
|
(let-values (((name)
|
|
|
|
|
(package-name package))
|
|
|
|
|
((archive-type)
|
|
|
|
|
(let ((source (package-source package)))
|
|
|
|
|
(or (and (origin? source)
|
|
|
|
|
(file-extension (origin-uri source)))
|
|
|
|
|
"gz"))))
|
|
|
|
|
(let ((tarball (download-tarball store name directory version
|
2013-06-10 09:46:13 +02:00
|
|
|
|
#:archive-type archive-type
|
|
|
|
|
#:key-download key-download)))
|
2013-04-24 23:48:36 +02:00
|
|
|
|
(values version tarball))))
|
|
|
|
|
(_
|
|
|
|
|
(values #f #f))))
|
|
|
|
|
|
|
|
|
|
(define (update-package-source package version hash)
|
|
|
|
|
"Modify the source file that defines PACKAGE to refer to VERSION,
|
|
|
|
|
whose tarball has SHA256 HASH (a bytevector). Return the new version string
|
|
|
|
|
if an update was made, and #f otherwise."
|
|
|
|
|
(define (new-line line matches replacement)
|
|
|
|
|
;; Iterate over MATCHES and return the modified line based on LINE.
|
|
|
|
|
;; Replace each match with REPLACEMENT.
|
|
|
|
|
(let loop ((m* matches) ; matches
|
|
|
|
|
(o 0) ; offset in L
|
|
|
|
|
(r '())) ; result
|
|
|
|
|
(match m*
|
|
|
|
|
(()
|
|
|
|
|
(let ((r (cons (substring line o) r)))
|
|
|
|
|
(string-concatenate-reverse r)))
|
|
|
|
|
((m . rest)
|
|
|
|
|
(loop rest
|
|
|
|
|
(match:end m)
|
|
|
|
|
(cons* replacement
|
|
|
|
|
(substring line o (match:start m))
|
|
|
|
|
r))))))
|
|
|
|
|
|
|
|
|
|
(define (update-source file old-version version
|
|
|
|
|
old-hash hash)
|
|
|
|
|
;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
|
|
|
|
|
;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
|
|
|
|
|
|
|
|
|
|
;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
|
|
|
|
|
;; different unrelated places, we may modify it more than needed, for
|
|
|
|
|
;; instance. We should try to make changes only within the sexp that
|
|
|
|
|
;; corresponds to the definition of PACKAGE.
|
|
|
|
|
(let ((old-hash (bytevector->nix-base32-string old-hash))
|
|
|
|
|
(hash (bytevector->nix-base32-string hash)))
|
|
|
|
|
(substitute file
|
|
|
|
|
`((,(regexp-quote old-version)
|
|
|
|
|
. ,(cut new-line <> <> version))
|
|
|
|
|
(,(regexp-quote old-hash)
|
|
|
|
|
. ,(cut new-line <> <> hash))))
|
|
|
|
|
version))
|
|
|
|
|
|
|
|
|
|
(let ((name (package-name package))
|
|
|
|
|
(loc (package-field-location package 'version)))
|
|
|
|
|
(if loc
|
|
|
|
|
(let ((old-version (package-version package))
|
|
|
|
|
(old-hash (origin-sha256 (package-source package)))
|
|
|
|
|
(file (and=> (location-file loc)
|
|
|
|
|
(cut search-path %load-path <>))))
|
|
|
|
|
(if file
|
|
|
|
|
(update-source file
|
|
|
|
|
old-version version
|
|
|
|
|
old-hash hash)
|
|
|
|
|
(begin
|
|
|
|
|
(warning (_ "~a: could not locate source file")
|
|
|
|
|
(location-file loc))
|
|
|
|
|
#f)))
|
|
|
|
|
(begin
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
(_ "~a: ~a: no `version' field in source; skipping~%")
|
2013-04-27 22:52:43 +02:00
|
|
|
|
(location->string (package-location package))
|
|
|
|
|
name)))))
|
2013-04-24 23:48:36 +02:00
|
|
|
|
|
2013-01-08 22:46:12 +01:00
|
|
|
|
;;; gnu-maintenance.scm ends here
|