[jackhill/guix/guix.git] / guix / gnu-maintenance.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; 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.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; 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
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix gnu-maintenance)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (system foreign)
  #:use-module (guix http-client)
  #:use-module (guix ftp-client)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix records)
  #:use-module (guix packages)
  #: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))
  #: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-description
            gnu-package-doc-urls
            gnu-package-download-url

            official-gnu-packages
            find-packages
            gnu-package?

            gnu-release?
            gnu-release-package
            gnu-release-version
            gnu-release-directory
            gnu-release-files

            releases
            latest-release
            gnu-release-archive-types
            gnu-package-name->name+version

            download-tarball
            package-update-path
            package-update
            update-package-source))

;;; Commentary:
;;;
;;; Code for dealing with the maintenance of GNU packages, such as
;;; auto-updates.
;;;
;;; Code:

\f
;;;
;;; List of GNU packages.
;;;

(define %gnumaint-base-url
  "http://cvs.savannah.gnu.org/viewvc/*checkout*/gnumaint/")

(define %package-list-url
  (string->uri
   (string-append %gnumaint-base-url "gnupackages.txt?root=womb")))

(define %package-description-url
  ;; This file contains package descriptions in recutils format.
  ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
  (string->uri
   (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))

(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)
  (language         gnu-package-language)         ; list of strings
  (logo             gnu-package-logo)
  (doc-category     gnu-package-doc-category)
  (doc-summary      gnu-package-doc-summary)
  (doc-description  gnu-package-doc-description)  ; taken from 'pkgdescr.txt'
  (doc-urls         gnu-package-doc-urls)         ; list of strings
  (download-url     gnu-package-download-url))

(define* (official-gnu-packages
          #:optional (fetch http-fetch/cached))
  "Return a list of records, which are GNU packages.  Use FETCH,
to fetch the list of GNU packages over HTTP."
  (define (read-records port)
    ;; Return a list of alists.  Each alist contains fields of a GNU
    ;; package.
    (let loop ((alist  (recutils->alist port))
               (result '()))
      (if (null? alist)
          (reverse result)
          (loop (recutils->alist port)
                (cons alist result)))))

  (define official-description
    (let ((db (read-records (fetch %package-description-url #:text? #t))))
      (lambda (name)
        ;; Return the description found upstream for package NAME, or #f.
        (and=> (find (lambda (alist)
                       (equal? name (assoc-ref alist "package")))
                     db)
               (lambda (record)
                 (let ((field (assoc-ref record "blurb")))
                   ;; The upstream description file uses "redirect PACKAGE" as
                   ;; a blurb in cases where the description of the two
                   ;; packages should be considered the same (e.g., GTK+ has
                   ;; "redirect gnome".)  This is usually not acceptable for
                   ;; us because we prefer to have distinct descriptions in
                   ;; such cases.  Thus, ignore the 'blurb' field when that
                   ;; happens.
                   (and field
                        (not (string-prefix? "redirect " field))
                        field)))))))

  (map (lambda (alist)
         (let ((name (assoc-ref alist "package")))
           (alist->record `(("description" . ,(official-description name))
                            ,@alist)
                          make-gnu-package-descriptor
                          (list "package" "mundane-name" "copyright-holder"
                                "savannah" "fsd" "language" "logo"
                                "doc-category" "doc-summary" "description"
                                "doc-url"
                                "download-url")
                          '("doc-url" "language"))))
       (let* ((port (fetch %package-list-url #:text? #t))
              (lst  (read-records port)))
         (close-port port)
         lst)))

(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))))

(define gnu-package?
  (memoize
   (let ((official-gnu-packages (memoize official-gnu-packages)))
     (lambda (package)
       "Return true if PACKAGE is a GNU package.  This procedure may access the
network to check in GNU's database."
       (define (mirror-type url)
         (let ((uri (string->uri url)))
           (and (eq? (uri-scheme uri) 'mirror)
                (cond
                 ((member (uri-host uri)
                          '("gnu" "gnupg" "gcc" "gnome"))
                  ;; Definitely GNU.
                  'gnu)
                 ((equal? (uri-host uri) "cran")
                  ;; Possibly GNU: mirror://cran could be either GNU R itself
                  ;; or a non-GNU package.
                  #f)
                 (else
                  ;; Definitely non-GNU.
                  'non-gnu)))))

       (define (gnu-home-page? package)
         (and=> (package-home-page package)
                (lambda (url)
                  (and=> (uri-host (string->uri url))
                         (lambda (host)
                           (member host '("www.gnu.org" "gnu.org")))))))

       (or (gnu-home-page? package)
           (let ((url  (and=> (package-source package) origin-uri))
                 (name (package-name package)))
             (case (and (string? url) (mirror-type url))
               ((gnu) #t)
               ((non-gnu) #f)
               (else
                (and (member name (map gnu-package-name (official-gnu-packages)))
                     #t)))))))))

\f
;;;
;;; Latest release.
;;;

(define-record-type* <gnu-release> gnu-release make-gnu-release
  gnu-release?
  (package    gnu-release-package)
  (version    gnu-release-version)
  (directory  gnu-release-directory)
  (files      gnu-release-files))

(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")
      ("glib"         "ftp.gnome.org" "/pub/gnome/sources/glib")
      ("gnutls"       "ftp.gnutls.org" "/gcrypt/gnutls")
      ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))

  (match (assoc project quirks)
    ((_ server directory)
     (values server directory))
    (_
     (values "ftp.gnu.org" (string-append "/gnu/" project)))))

(define (sans-extension tarball)
  "Return TARBALL without its .tar.* or .zip extension."
  (let ((end (or (string-contains tarball ".tar")
                 (string-contains tarball ".zip"))))
    (substring tarball 0 end)))

(define %tarball-rx
  ;; Note: .zip files are notably used for freefont-ttf.
  (make-regexp "^(.+)-([0-9]|[^-])*(-src)?\\.(tar\\.|zip$)"))

(define %alpha-tarball-rx
  (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))

(define (release-file? project file)
  "Return #f if FILE is not a release tarball of PROJECT, otherwise return
true."
  (and (not (string-suffix? ".sig" file))
       (and=> (regexp-exec %tarball-rx file)
              (lambda (match)
                ;; Filter out unrelated files, like `guile-www-1.1.1'.
                (equal? project (match:substring match 1))))
       (not (regexp-exec %alpha-tarball-rx file))
       (let ((s (sans-extension file)))
         (regexp-exec %package-name-rx s))))

(define (tarball->version tarball)
  "Return the version TARBALL corresponds to.  TARBALL is a file name like
\"coreutils-8.23.tar.xz\"."
  (let-values (((name version)
                (gnu-package-name->name+version (sans-extension tarball))))
    version))

(define (coalesce-releases releases)
  "Coalesce the elements of RELEASES that correspond to the same version."
  (define (same-version? r1 r2)
    (string=? (gnu-release-version r1) (gnu-release-version r2)))

  (define (release>? r1 r2)
    (version>? (gnu-release-version r1) (gnu-release-version r2)))

  (fold (lambda (release result)
          (match result
            ((head . tail)
             (if (same-version? release head)
                 (cons (gnu-release
                        (inherit release)
                        (files (append (gnu-release-files release)
                                       (gnu-release-files head))))
                       tail)
                 (cons release result)))
            (()
             (list release))))
        '()
        (sort releases release>?)))

(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.
  (let-values (((server directory) (ftp-server/directory project)))
    (define conn (ftp-open server))

    (let loop ((directories (list directory))
               (result      '()))
      (match directories
        (()
         (ftp-close conn)
         (coalesce-releases 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 . _)
                                (if (release-file? project file)
                                    (gnu-release
                                     (package project)
                                     (version (tarball->version file))
                                     (directory directory)
                                     (files (list file)))
                                    #f))
                               (_ #f))
                              files)
                  result))))))))

(define* (latest-release project
                         #:key (ftp-open ftp-open) (ftp-close ftp-close))
  "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f.  Use FTP-OPEN and FTP-CLOSE to
open (resp. close) FTP connections; this can be useful to reuse connections."
  (define (latest a b)
    (if (version>? a b) a b))

  (define (latest-release a b)
    (if (version>? (gnu-release-version a) (gnu-release-version b))
        a b))

  (define contains-digit?
    (cut string-any char-set:digit <>))

  (define patch-directory-name?
    ;; Return #t for patch directory names such as 'bash-4.2-patches'.
    (cut string-suffix? "patches" <>))

  (let-values (((server directory) (ftp-server/directory project)))
    (define conn (ftp-open server))

    (let loop ((directory directory)
               (result    #f))
      (let* ((entries (ftp-list conn directory))

             ;; Filter out sub-directories that do not contain digits---e.g.,
             ;; /gnuzilla/lang and /gnupg/patches.
             (subdirs (filter-map (match-lambda
                                   (((? patch-directory-name? dir)
                                     'directory . _)
                                    #f)
                                   (((? contains-digit? dir) 'directory . _)
                                    dir)
                                   (_ #f))
                                  entries))

             ;; Whether or not SUBDIRS is empty, compute the latest releases
             ;; for the current directory.  This is necessary for packages
             ;; such as 'sharutils' that have a sub-directory that contains
             ;; only an older release.
             (releases (filter-map (match-lambda
                                     ((file 'file . _)
                                      (and (release-file? project file)
                                           (gnu-release
                                            (package project)
                                            (version
                                             (tarball->version file))
                                            (directory directory)
                                            (files (list file)))))
                                     (_ #f))
                                   entries)))

        ;; Assume that SUBDIRS correspond to versions, and jump into the
        ;; one with the highest version number.
        (let* ((release  (reduce latest-release #f
                                 (coalesce-releases releases)))
               (result   (if (and result release)
                             (latest-release release result)
                             (or release result)))
               (target   (reduce latest #f subdirs)))
          (if target
              (loop (string-append directory "/" target)
                    result)
              (begin
                (ftp-close conn)
                result)))))))

(define (gnu-release-archive-types release)
  "Return the available types of archives for RELEASE---a list of strings such
as \"gz\" or \"xz\"."
  (map file-extension (gnu-release-files release)))

(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)))))

\f
;;;
;;; 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))
         (($ <gnu-release> name version directory)
          (and (version>? version (package-version package))
               `(,version . ,directory)))
         (_ #f))))

(define* (download-tarball store project directory version
                           #:key (archive-type "gz")
                                 (key-download 'interactive))
  "Download PROJECT's tarball over FTP and check its OpenPGP signature.  On
success, return the tarball file name.  KEY-DOWNLOAD specifies a download
policy for missing OpenPGP keys; allowed values: 'interactive' (default),
'always', and 'never'."
  (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)))
    (let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
      (if ret
          tarball
          (begin
            (warning (_ "signature verification failed for `~a'~%")
                     base)
            (warning (_ "(could be because the public key is not in your keyring)~%"))
            #f)))))

(define* (package-update store package #:key (key-download 'interactive))
  "Return the new version and the file name of the new version tarball for
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)."
  (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
                                        #:archive-type archive-type
                                        #:key-download key-download)))
         (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~%")
                  (location->string (package-location package))
                  name)))))

;;; gnu-maintenance.scm ends here
Commit	Line	Data
233e7676	1	;;; GNU Guix --- Functional package management for GNU
c4e8d513	2	;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
f9bbf2a8	3	;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
22189ed1	4	;;;
233e7676	5	;;; This file is part of GNU Guix.
22189ed1	6	;;;
233e7676	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
22189ed1 NK	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	;;;
233e7676	12	;;; GNU Guix is distributed in the hope that it will be useful, but
22189ed1 NK	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
233e7676	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22189ed1 NK	19
	20	(define-module (guix gnu-maintenance)
	21	#:use-module (web uri)
	22	#:use-module (web client)
	23	#:use-module (web response)
	24	#:use-module (ice-9 regex)
98fefb21	25	#:use-module (ice-9 match)
22189ed1 NK	26	#:use-module (srfi srfi-1)
	27	#:use-module (srfi srfi-11)
	28	#:use-module (srfi srfi-26)
98fefb21	29	#:use-module (system foreign)
3b8258c5	30	#:use-module (guix http-client)
98fefb21	31	#:use-module (guix ftp-client)
98eb8cbe	32	#:use-module (guix ui)
0d1e6ce4	33	#:use-module (guix utils)
c0cd1b3e	34	#:use-module (guix records)
ef010c0f	35	#:use-module (guix packages)
0fdd3bea LC	36	#:use-module ((guix download) #:select (download-to-store))
	37	#:use-module (guix gnupg)
	38	#:use-module (rnrs io ports)
	39	#:use-module (guix base32)
	40	#:use-module ((guix build utils)
	41	#:select (substitute))
f9bbf2a8 NK	42	#:export (gnu-package-name
	43	gnu-package-mundane-name
	44	gnu-package-copyright-holder
	45	gnu-package-savannah
	46	gnu-package-fsd
	47	gnu-package-language
	48	gnu-package-logo
	49	gnu-package-doc-category
	50	gnu-package-doc-summary
c4ca9411	51	gnu-package-doc-description
f9bbf2a8 NK	52	gnu-package-doc-urls
	53	gnu-package-download-url
	54
	55	official-gnu-packages
	56	find-packages
ef010c0f	57	gnu-package?
f9bbf2a8	58
501d7647 LC	59	gnu-release?
	60	gnu-release-package
	61	gnu-release-version
	62	gnu-release-directory
	63	gnu-release-files
	64
98fefb21 LC	65	releases
98fefb21 LC	66	latest-release
7047133f	67	gnu-release-archive-types
0fdd3bea	68	gnu-package-name->name+version
7047133f LC	69
7047133f LC	70	download-tarball
0fdd3bea LC	71	package-update-path
	72	package-update
	73	update-package-source))
98fefb21 LC	74
	75	;;; Commentary:
	76	;;;
	77	;;; Code for dealing with the maintenance of GNU packages, such as
	78	;;; auto-updates.
	79	;;;
	80	;;; Code:
	81
	82	\f
	83	;;;
	84	;;; List of GNU packages.
	85	;;;
22189ed1	86
129f9e11 LC	87	(define %gnumaint-base-url
	88	"http://cvs.savannah.gnu.org/viewvc/checkout/gnumaint/")
	89
22189ed1	90	(define %package-list-url
1c9e7d65	91	(string->uri
129f9e11	92	(string-append %gnumaint-base-url "gnupackages.txt?root=womb")))
22189ed1	93
129f9e11 LC	94	(define %package-description-url
	95	;; This file contains package descriptions in recutils format.
	96	;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
	97	(string->uri
1a75f8d9	98	(string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))
c4ca9411	99
f9bbf2a8 NK	100	(define-record-type* <gnu-package-descriptor>
	101	gnu-package-descriptor
	102	make-gnu-package-descriptor
	103
	104	gnu-package-descriptor?
	105
	106	(name gnu-package-name)
	107	(mundane-name gnu-package-mundane-name)
	108	(copyright-holder gnu-package-copyright-holder)
	109	(savannah gnu-package-savannah)
	110	(fsd gnu-package-fsd)
b0efe83a	111	(language gnu-package-language) ; list of strings
f9bbf2a8 NK	112	(logo gnu-package-logo)
	113	(doc-category gnu-package-doc-category)
	114	(doc-summary gnu-package-doc-summary)
129f9e11	115	(doc-description gnu-package-doc-description) ; taken from 'pkgdescr.txt'
b0efe83a	116	(doc-urls gnu-package-doc-urls) ; list of strings
f9bbf2a8 NK	117	(download-url gnu-package-download-url))
f9bbf2a8 NK	118
9aec35d2 LC	119	(define* (official-gnu-packages
	120	#:optional (fetch http-fetch/cached))
	121	"Return a list of records, which are GNU packages. Use FETCH,
	122	to fetch the list of GNU packages over HTTP."
c4ca9411	123	(define (read-records port)
f9bbf2a8 NK	124	;; Return a list of alists. Each alist contains fields of a GNU
f9bbf2a8 NK	125	;; package.
b0efe83a LC	126	(let loop ((alist (recutils->alist port))
	127	(result '()))
	128	(if (null? alist)
c4ca9411	129	(reverse result)
b0efe83a LC	130	(loop (recutils->alist port)
b0efe83a LC	131	(cons alist result)))))
f9bbf2a8	132
129f9e11	133	(define official-description
9aec35d2	134	(let ((db (read-records (fetch %package-description-url #:text? #t))))
c4ca9411	135	(lambda (name)
129f9e11	136	;; Return the description found upstream for package NAME, or #f.
c4ca9411	137	(and=> (find (lambda (alist)
129f9e11 LC	138	(equal? name (assoc-ref alist "package")))
129f9e11 LC	139	db)
4d5f0bae LC	140	(lambda (record)
	141	(let ((field (assoc-ref record "blurb")))
	142	;; The upstream description file uses "redirect PACKAGE" as
	143	;; a blurb in cases where the description of the two
	144	;; packages should be considered the same (e.g., GTK+ has
	145	;; "redirect gnome".) This is usually not acceptable for
	146	;; us because we prefer to have distinct descriptions in
	147	;; such cases. Thus, ignore the 'blurb' field when that
	148	;; happens.
	149	(and field
	150	(not (string-prefix? "redirect " field))
	151	field)))))))
c4ca9411 LC	152
	153	(map (lambda (alist)
	154	(let ((name (assoc-ref alist "package")))
129f9e11	155	(alist->record `(("description" . ,(official-description name))
c4ca9411 LC	156	,@alist)
	157	make-gnu-package-descriptor
	158	(list "package" "mundane-name" "copyright-holder"
	159	"savannah" "fsd" "language" "logo"
	160	"doc-category" "doc-summary" "description"
	161	"doc-url"
	162	"download-url")
	163	'("doc-url" "language"))))
2134228a LC	164	(let* ((port (fetch %package-list-url #:text? #t))
	165	(lst (read-records port)))
	166	(close-port port)
	167	lst)))
22189ed1	168
f9bbf2a8 NK	169	(define (find-packages regexp)
	170	"Find GNU packages which satisfy REGEXP."
	171	(let ((name-rx (make-regexp regexp)))
	172	(filter (lambda (package)
	173	(false-if-exception
	174	(regexp-exec name-rx (gnu-package-name package))))
	175	(official-gnu-packages))))
ef010c0f LC	176
	177	(define gnu-package?
	178	(memoize
65b96a0c LC	179	(let ((official-gnu-packages (memoize official-gnu-packages)))
	180	(lambda (package)
	181	"Return true if PACKAGE is a GNU package. This procedure may access the
ef010c0f	182	network to check in GNU's database."
187eb5f6 LC	183	(define (mirror-type url)
	184	(let ((uri (string->uri url)))
	185	(and (eq? (uri-scheme uri) 'mirror)
c4e8d513 LC	186	(cond
	187	((member (uri-host uri)
	188	'("gnu" "gnupg" "gcc" "gnome"))
	189	;; Definitely GNU.
	190	'gnu)
	191	((equal? (uri-host uri) "cran")
	192	;; Possibly GNU: mirror://cran could be either GNU R itself
	193	;; or a non-GNU package.
	194	#f)
	195	(else
	196	;; Definitely non-GNU.
	197	'non-gnu)))))
187eb5f6	198
55d1f529 LC	199	(define (gnu-home-page? package)
	200	(and=> (package-home-page package)
	201	(lambda (url)
	202	(and=> (uri-host (string->uri url))
	203	(lambda (host)
	204	(member host '("www.gnu.org" "gnu.org")))))))
	205
	206	(or (gnu-home-page? package)
	207	(let ((url (and=> (package-source package) origin-uri))
	208	(name (package-name package)))
	209	(case (and (string? url) (mirror-type url))
	210	((gnu) #t)
	211	((non-gnu) #f)
	212	(else
	213	(and (member name (map gnu-package-name (official-gnu-packages)))
	214	#t)))))))))
ef010c0f	215
98fefb21 LC	216	\f
	217	;;;
	218	;;; Latest release.
	219	;;;
	220
501d7647 LC	221	(define-record-type* <gnu-release> gnu-release make-gnu-release
	222	gnu-release?
	223	(package gnu-release-package)
	224	(version gnu-release-version)
	225	(directory gnu-release-directory)
	226	(files gnu-release-files))
	227
98fefb21 LC	228	(define (ftp-server/directory project)
	229	"Return the FTP server and directory where PROJECT's tarball are
	230	stored."
	231	(define quirks
	232	'(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp")
	233	("ucommon" "ftp.gnu.org" "/gnu/commoncpp")
	234	("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp")
	235	("libosip2" "ftp.gnu.org" "/gnu/osip")
	236	("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt")
	237	("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
	238	("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan")
	239	("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg")
	240	("freefont-ttf" "ftp.gnu.org" "/gnu/freefont")
	241	("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript")
	242	("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
	243	("icecat" "ftp.gnu.org" "/gnu/gnuzilla")
	244	("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
0fdd3bea	245	("glib" "ftp.gnome.org" "/pub/gnome/sources/glib")
a4007c98	246	("gnutls" "ftp.gnutls.org" "/gcrypt/gnutls")
98fefb21 LC	247	("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz")))
	248
	249	(match (assoc project quirks)
	250	((_ server directory)
	251	(values server directory))
	252	(_
	253	(values "ftp.gnu.org" (string-append "/gnu/" project)))))
	254
cac137aa	255	(define (sans-extension tarball)
f5d9604f LC	256	"Return TARBALL without its .tar.* or .zip extension."
	257	(let ((end (or (string-contains tarball ".tar")
	258	(string-contains tarball ".zip"))))
cac137aa	259	(substring tarball 0 end)))
98fefb21	260
d55a99fe	261	(define %tarball-rx
f5d9604f LC	262	;; Note: .zip files are notably used for freefont-ttf.
f5d9604f LC	263	(make-regexp "^(.+)-([0-9]\|[^-])*(-src)?\\.(tar\\.\|zip$)"))
d55a99fe LC	264
	265	(define %alpha-tarball-rx
	266	(make-regexp "^.-.[0-9](-\|~)?(alpha\|beta\|rc\|cvs\|svn\|git)-?[0-9\\.]*\\.tar\\."))
	267
501d7647	268	(define (release-file? project file)
cac137aa	269	"Return #f if FILE is not a release tarball of PROJECT, otherwise return
501d7647	270	true."
cac137aa	271	(and (not (string-suffix? ".sig" file))
d55a99fe LC	272	(and=> (regexp-exec %tarball-rx file)
	273	(lambda (match)
	274	;; Filter out unrelated files, like `guile-www-1.1.1'.
	275	(equal? project (match:substring match 1))))
cac137aa LC	276	(not (regexp-exec %alpha-tarball-rx file))
cac137aa LC	277	(let ((s (sans-extension file)))
501d7647 LC	278	(regexp-exec %package-name-rx s))))
	279
	280	(define (tarball->version tarball)
	281	"Return the version TARBALL corresponds to. TARBALL is a file name like
	282	\"coreutils-8.23.tar.xz\"."
	283	(let-values (((name version)
	284	(gnu-package-name->name+version (sans-extension tarball))))
	285	version))
	286
	287	(define (coalesce-releases releases)
	288	"Coalesce the elements of RELEASES that correspond to the same version."
	289	(define (same-version? r1 r2)
	290	(string=? (gnu-release-version r1) (gnu-release-version r2)))
	291
	292	(define (release>? r1 r2)
	293	(version>? (gnu-release-version r1) (gnu-release-version r2)))
	294
	295	(fold (lambda (release result)
	296	(match result
	297	((head . tail)
	298	(if (same-version? release head)
	299	(cons (gnu-release
	300	(inherit release)
	301	(files (append (gnu-release-files release)
	302	(gnu-release-files head))))
	303	tail)
	304	(cons release result)))
	305	(()
	306	(list release))))
	307	'()
	308	(sort releases release>?)))
6a917ef7	309
cac137aa LC	310	(define (releases project)
	311	"Return the list of releases of PROJECT as a list of release name/directory
	312	pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
	313	;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
98fefb21 LC	314	(let-values (((server directory) (ftp-server/directory project)))
	315	(define conn (ftp-open server))
	316
	317	(let loop ((directories (list directory))
	318	(result '()))
6a917ef7 LC	319	(match directories
	320	(()
	321	(ftp-close conn)
501d7647	322	(coalesce-releases result))
6a917ef7 LC	323	((directory rest ...)
	324	(let* ((files (ftp-list conn directory))
	325	(subdirs (filter-map (match-lambda
	326	((name 'directory . _) name)
	327	(_ #f))
	328	files)))
	329	(loop (append (map (cut string-append directory "/" <>)
	330	subdirs)
	331	rest)
	332	(append
	333	;; Filter out signatures, deltas, and files which
	334	;; are potentially not releases of PROJECT--e.g.,
	335	;; in /gnu/guile, filter out guile-oops and
	336	;; guile-www; in mit-scheme, filter out binaries.
	337	(filter-map (match-lambda
501d7647 LC	338	((file 'file . _)
	339	(if (release-file? project file)
	340	(gnu-release
	341	(package project)
	342	(version (tarball->version file))
	343	(directory directory)
	344	(files (list file)))
	345	#f))
	346	(_ #f))
6a917ef7 LC	347	files)
6a917ef7 LC	348	result))))))))
98fefb21	349
e3ccdf9e LC	350	(define* (latest-release project
	351	#:key (ftp-open ftp-open) (ftp-close ftp-close))
	352	"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f. Use FTP-OPEN and FTP-CLOSE to
	353	open (resp. close) FTP connections; this can be useful to reuse connections."
cac137aa LC	354	(define (latest a b)
	355	(if (version>? a b) a b))
	356
501d7647 LC	357	(define (latest-release a b)
	358	(if (version>? (gnu-release-version a) (gnu-release-version b))
	359	a b))
	360
cac137aa LC	361	(define contains-digit?
	362	(cut string-any char-set:digit <>))
	363
a74da6b0 LC	364	(define patch-directory-name?
	365	;; Return #t for patch directory names such as 'bash-4.2-patches'.
	366	(cut string-suffix? "patches" <>))
	367
cac137aa LC	368	(let-values (((server directory) (ftp-server/directory project)))
	369	(define conn (ftp-open server))
	370
d7bc3470 LC	371	(let loop ((directory directory)
d7bc3470 LC	372	(result #f))
cac137aa	373	(let* ((entries (ftp-list conn directory))
049b2f1d LC	374
	375	;; Filter out sub-directories that do not contain digits---e.g.,
	376	;; /gnuzilla/lang and /gnupg/patches.
cac137aa	377	(subdirs (filter-map (match-lambda
a74da6b0 LC	378	(((? patch-directory-name? dir)
	379	'directory . _)
	380	#f)
049b2f1d LC	381	(((? contains-digit? dir) 'directory . _)
049b2f1d LC	382	dir)
cac137aa	383	(_ #f))
d7bc3470 LC	384	entries))
	385
	386	;; Whether or not SUBDIRS is empty, compute the latest releases
	387	;; for the current directory. This is necessary for packages
	388	;; such as 'sharutils' that have a sub-directory that contains
	389	;; only an older release.
	390	(releases (filter-map (match-lambda
	391	((file 'file . _)
	392	(and (release-file? project file)
	393	(gnu-release
	394	(package project)
	395	(version
	396	(tarball->version file))
	397	(directory directory)
	398	(files (list file)))))
	399	(_ #f))
	400	entries)))
	401
	402	;; Assume that SUBDIRS correspond to versions, and jump into the
	403	;; one with the highest version number.
	404	(let* ((release (reduce latest-release #f
	405	(coalesce-releases releases)))
	406	(result (if (and result release)
	407	(latest-release release result)
	408	(or release result)))
	409	(target (reduce latest #f subdirs)))
	410	(if target
	411	(loop (string-append directory "/" target)
	412	result)
	413	(begin
	414	(ftp-close conn)
	415	result)))))))
98fefb21	416
7047133f LC	417	(define (gnu-release-archive-types release)
	418	"Return the available types of archives for RELEASE---a list of strings such
	419	as \"gz\" or \"xz\"."
	420	(map file-extension (gnu-release-files release)))
	421
98fefb21 LC	422	(define %package-name-rx
	423	;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
	424	;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
	425	(make-regexp "^(.*)-(([0-9]\|\\.)+)(-src)?"))
	426
	427	(define (gnu-package-name->name+version name+version)
	428	"Return the package name and version number extracted from NAME+VERSION."
	429	(let ((match (regexp-exec %package-name-rx name+version)))
	430	(if (not match)
	431	(values name+version #f)
	432	(values (match:substring match 1) (match:substring match 2)))))
	433
0fdd3bea LC	434	\f
	435	;;;
	436	;;; Auto-update.
	437	;;;
	438
	439	(define (package-update-path package)
	440	"Return an update path for PACKAGE, or #f if no update is needed."
	441	(and (gnu-package? package)
	442	(match (latest-release (package-name package))
501d7647 LC	443	(($ <gnu-release> name version directory)
	444	(and (version>? version (package-version package))
	445	`(,version . ,directory)))
0fdd3bea LC	446	(_ #f))))
	447
	448	(define* (download-tarball store project directory version
392b5d8c NK	449	#:key (archive-type "gz")
392b5d8c NK	450	(key-download 'interactive))
0fdd3bea	451	"Download PROJECT's tarball over FTP and check its OpenPGP signature. On
392b5d8c NK	452	success, return the tarball file name. KEY-DOWNLOAD specifies a download
	453	policy for missing OpenPGP keys; allowed values: 'interactive' (default),
	454	'always', and 'never'."
0fdd3bea LC	455	(let* ((server (ftp-server/directory project))
	456	(base (string-append project "-" version ".tar." archive-type))
	457	(url (string-append "ftp://" server "/" directory "/" base))
	458	(sig-url (string-append url ".sig"))
	459	(tarball (download-to-store store url))
	460	(sig (download-to-store store sig-url)))
392b5d8c	461	(let ((ret (gnupg-verify* sig tarball #:key-download key-download)))
0fdd3bea LC	462	(if ret
	463	tarball
	464	(begin
dfb43e45	465	(warning (_ "signature verification failed for `~a'~%")
0fdd3bea	466	base)
dfb43e45	467	(warning (_ "(could be because the public key is not in your keyring)~%"))
0fdd3bea LC	468	#f)))))
0fdd3bea LC	469
392b5d8c	470	(define* (package-update store package #:key (key-download 'interactive))
0fdd3bea	471	"Return the new version and the file name of the new version tarball for
392b5d8c NK	472	PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a
	473	download policy for missing OpenPGP keys; allowed values: 'always', 'never',
	474	and 'interactive' (default)."
0fdd3bea LC	475	(match (package-update-path package)
	476	((version . directory)
	477	(let-values (((name)
	478	(package-name package))
	479	((archive-type)
	480	(let ((source (package-source package)))
	481	(or (and (origin? source)
	482	(file-extension (origin-uri source)))
	483	"gz"))))
	484	(let ((tarball (download-tarball store name directory version
392b5d8c NK	485	#:archive-type archive-type
392b5d8c NK	486	#:key-download key-download)))
0fdd3bea LC	487	(values version tarball))))
	488	(_
	489	(values #f #f))))
	490
	491	(define (update-package-source package version hash)
	492	"Modify the source file that defines PACKAGE to refer to VERSION,
	493	whose tarball has SHA256 HASH (a bytevector). Return the new version string
	494	if an update was made, and #f otherwise."
	495	(define (new-line line matches replacement)
	496	;; Iterate over MATCHES and return the modified line based on LINE.
	497	;; Replace each match with REPLACEMENT.
	498	(let loop ((m* matches) ; matches
	499	(o 0) ; offset in L
	500	(r '())) ; result
	501	(match m*
	502	(()
	503	(let ((r (cons (substring line o) r)))
	504	(string-concatenate-reverse r)))
	505	((m . rest)
	506	(loop rest
	507	(match:end m)
	508	(cons* replacement
	509	(substring line o (match:start m))
	510	r))))))
	511
	512	(define (update-source file old-version version
	513	old-hash hash)
	514	;; Update source file FILE, replacing occurrences OLD-VERSION by VERSION
	515	;; and occurrences of OLD-HASH by HASH (base32 representation thereof).
	516
	517	;; TODO: Currently this is a bit of a sledgehammer: if VERSION occurs in
	518	;; different unrelated places, we may modify it more than needed, for
	519	;; instance. We should try to make changes only within the sexp that
	520	;; corresponds to the definition of PACKAGE.
	521	(let ((old-hash (bytevector->nix-base32-string old-hash))
	522	(hash (bytevector->nix-base32-string hash)))
	523	(substitute file
	524	`((,(regexp-quote old-version)
	525	. ,(cut new-line <> <> version))
	526	(,(regexp-quote old-hash)
	527	. ,(cut new-line <> <> hash))))
	528	version))
	529
	530	(let ((name (package-name package))
	531	(loc (package-field-location package 'version)))
	532	(if loc
	533	(let ((old-version (package-version package))
	534	(old-hash (origin-sha256 (package-source package)))
	535	(file (and=> (location-file loc)
	536	(cut search-path %load-path <>))))
	537	(if file
	538	(update-source file
	539	old-version version
	540	old-hash hash)
	541	(begin
	542	(warning (_ "~a: could not locate source file")
	543	(location-file loc))
	544	#f)))
	545	(begin
	546	(format (current-error-port)
	547	(_ "~a: ~a: no `version' field in source; skipping~%")
c4ca12c1 LC	548	(location->string (package-location package))
c4ca12c1 LC	549	name)))))
0fdd3bea	550
98fefb21	551	;;; gnu-maintenance.scm ends here