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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2010, 2011, 2012, 2013 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 rdelim)
  #: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 ftp-client)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #: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
            gnu-package?

            releases
            latest-release
            gnu-package-name->name+version))

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

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

(define (http-fetch uri)
  "Return an input port containing the textual data at URI, a string."
  (let*-values (((resp data)
                 (let ((uri (string->uri uri)))
                   ;; Try hard to use the API du jour to get an input port.
                   (if (version>? "2.0.7" (version))
                       (if (defined? 'http-get*)
                           (http-get* uri)
                           (http-get uri))       ; old Guile, returns a string
                       (http-get uri #:streaming? #t)))) ; 2.0.8 or later
               ((code)
                (response-code resp)))
    (case code
      ((200)
       (cond ((not data)
              (begin
                ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer
                ;; encoding, which is required when fetching %PACKAGE-LIST-URL
                ;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
                ;; Since users may still be using these versions, warn them and
                ;; bail out.
                (warning (_ "using Guile ~a, ~a ~s encoding~%")
                         (version)
                         "which does not support HTTP"
                         (response-transfer-encoding resp))
                (leave (_ "download failed; use a newer Guile~%")
                       uri resp)))
             ((string? data)                 ; old `http-get' returns a string
              (open-input-string data))
             (else                           ; input port
              data)))
      (else
       (error "download failed" uri code
              (response-reason-phrase resp))))))

(define %package-list-url
  (string-append "http://cvs.savannah.gnu.org/"
                 "viewvc/*checkout*/gnumaint/"
                 "gnupackages.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)
  (logo             gnu-package-logo)
  (doc-category     gnu-package-doc-category)
  (doc-summary      gnu-package-doc-summary)
  (doc-urls         gnu-package-doc-urls)
  (download-url     gnu-package-download-url))

(define (official-gnu-packages)
  "Return a list of records, which are GNU packages."
  (define (group-package-fields port state)
    ;; Return a list of alists.  Each alist contains fields of a GNU
    ;; package.
    (let ((line        (read-line port))
          (field-rx    (make-regexp "^([[:graph:]]+): (.*)$"))
          (doc-urls-rx (make-regexp "^doc-url: (.*)$"))
          (end-rx      (make-regexp "^# End. .+Do not remove this line.+")))

      (define (match-field str)
        ;; Packages are separated by empty strings.  If STR is an
        ;; empty string, create a new list to store fields of a
        ;; different package.  Otherwise, match and create a key-value
        ;; pair.
        (match str
          (""
           (group-package-fields port (cons '() state)))
          (str
           (cond ((regexp-exec doc-urls-rx str)
                  =>
                  (lambda (match)
                    (if (equal? (assoc-ref (first state) "doc-urls") #f)
                        (group-package-fields
                         port (cons (cons (cons "doc-urls"
                                                (list
                                                 (match:substring match 1)))
                                          (first state))
                                    (drop state 1)))
                        (group-package-fields
                         port (cons (cons (cons "doc-urls"
                                                (cons (match:substring match 1)
                                                      (assoc-ref (first state)
                                                                 "doc-urls")))
                                          (assoc-remove! (first state)
                                                         "doc-urls"))
                                    (drop state 1))))))
                 ((regexp-exec field-rx str)
                  =>
                  (lambda (match)
                    (group-package-fields
                     port (cons (cons (cons (match:substring match 1)
                                            (match:substring match 2))
                                      (first state))
                                (drop state 1)))))
                 (else (group-package-fields port state))))))

      (if (or (eof-object? line)
              (regexp-exec end-rx line)) ; don't include dummy fields
          (remove null-list? state)
          (match-field line))))

  (define (alist->record alist make keys)
    ;; Apply MAKE, which should be a syntactic constructor, to the
    ;; values associated with KEYS in ALIST.
    (let ((args (map (cut assoc-ref alist <>) keys)))
      (apply make args)))

  (reverse
   (map (lambda (alist)
          (alist->record alist
                         make-gnu-package-descriptor
                         (list "package" "mundane-name" "copyright-holder"
                               "savannah" "fsd" "language" "logo"
                               "doc-category" "doc-summary" "doc-urls"
                               "download-url")))
        (group-package-fields (http-fetch %package-list-url)
                              '(())))))

(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
   (lambda (package)
     "Return true if PACKAGE is a GNU package.  This procedure may access the
network to check in GNU's database."
     ;; 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))))))

\f
;;;
;;; 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")
      ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))

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

(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.
  (define release-rx
    (make-regexp (string-append "^" project
                                "-([0-9]|[^-])*(-src)?\\.tar\\.")))

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

  (define (sans-extension tarball)
    (let ((end (string-contains tarball ".tar")))
      (substring tarball 0 end)))

  (define (release-file file)
    ;; Return #f if FILE is not a release tarball, otherwise return
    ;; PACKAGE-VERSION.
    (and (not (string-suffix? ".sig" file))
         (regexp-exec release-rx file)
         (not (regexp-exec alpha-rx file))
         (let ((s (sans-extension file)))
           (and (regexp-exec %package-name-rx s) s))))

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

    (let loop ((directories (list directory))
               (result      '()))
      (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 . _)
                                 (and=> (release-file file)
                                        (cut cons <> directory)))
                                (_ #f))
                              files)
                  result))))))))

(define (latest-release project)
  "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
  (let ((releases (releases project)))
    (and (not (null? releases))
         (fold (lambda (release latest)
                 (if (version>? (car release) (car latest))
                     release
                     latest))
               '("" . "")
               releases))))

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

;;; gnu-maintenance.scm ends here
Commit	Line	Data
233e7676	1	;;; GNU Guix --- Functional package management for GNU
98fefb21	2	;;; Copyright © 2010, 2011, 2012, 2013 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)
f9bbf2a8	25	#:use-module (ice-9 rdelim)
98fefb21	26	#:use-module (ice-9 match)
22189ed1 NK	27	#:use-module (srfi srfi-1)
	28	#:use-module (srfi srfi-11)
	29	#:use-module (srfi srfi-26)
98fefb21 LC	30	#:use-module (system foreign)
98fefb21 LC	31	#:use-module (guix ftp-client)
98eb8cbe	32	#:use-module (guix ui)
0d1e6ce4	33	#:use-module (guix utils)
ef010c0f	34	#:use-module (guix packages)
f9bbf2a8 NK	35	#:export (gnu-package-name
	36	gnu-package-mundane-name
	37	gnu-package-copyright-holder
	38	gnu-package-savannah
	39	gnu-package-fsd
	40	gnu-package-language
	41	gnu-package-logo
	42	gnu-package-doc-category
	43	gnu-package-doc-summary
	44	gnu-package-doc-urls
	45	gnu-package-download-url
	46
	47	official-gnu-packages
	48	find-packages
ef010c0f	49	gnu-package?
f9bbf2a8	50
98fefb21 LC	51	releases
	52	latest-release
	53	gnu-package-name->name+version))
	54
	55	;;; Commentary:
	56	;;;
	57	;;; Code for dealing with the maintenance of GNU packages, such as
	58	;;; auto-updates.
	59	;;;
	60	;;; Code:
	61
	62	\f
	63	;;;
	64	;;; List of GNU packages.
	65	;;;
22189ed1 NK	66
22189ed1 NK	67	(define (http-fetch uri)
f9bbf2a8	68	"Return an input port containing the textual data at URI, a string."
22189ed1	69	(let*-values (((resp data)
ef8c0340 LC	70	(let ((uri (string->uri uri)))
	71	;; Try hard to use the API du jour to get an input port.
	72	(if (version>? "2.0.7" (version))
	73	(if (defined? 'http-get*)
	74	(http-get* uri)
	75	(http-get uri)) ; old Guile, returns a string
	76	(http-get uri #:streaming? #t)))) ; 2.0.8 or later
22189ed1 NK	77	((code)
	78	(response-code resp)))
	79	(case code
	80	((200)
ef8c0340	81	(cond ((not data)
f9bbf2a8 NK	82	(begin
	83	;; XXX: Guile 2.0.5 and earlier did not support chunked transfer
	84	;; encoding, which is required when fetching %PACKAGE-LIST-URL
	85	;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
	86	;; Since users may still be using these versions, warn them and
	87	;; bail out.
98eb8cbe NK	88	(warning (_ "using Guile ~a, ~a ~s encoding~%")
	89	(version)
	90	"which does not support HTTP"
	91	(response-transfer-encoding resp))
	92	(leave (_ "download failed; use a newer Guile~%")
f9bbf2a8	93	uri resp)))
ef8c0340	94	((string? data) ; old `http-get' returns a string
f9bbf2a8	95	(open-input-string data))
ef8c0340 LC	96	(else ; input port
ef8c0340 LC	97	data)))
22189ed1	98	(else
f9bbf2a8	99	(error "download failed" uri code
22189ed1 NK	100	(response-reason-phrase resp))))))
	101
	102	(define %package-list-url
	103	(string-append "http://cvs.savannah.gnu.org/"
	104	"viewvc/checkout/gnumaint/"
	105	"gnupackages.txt?root=womb"))
	106
f9bbf2a8 NK	107	(define-record-type* <gnu-package-descriptor>
	108	gnu-package-descriptor
	109	make-gnu-package-descriptor
	110
	111	gnu-package-descriptor?
	112
	113	(name gnu-package-name)
	114	(mundane-name gnu-package-mundane-name)
	115	(copyright-holder gnu-package-copyright-holder)
	116	(savannah gnu-package-savannah)
	117	(fsd gnu-package-fsd)
	118	(language gnu-package-language)
	119	(logo gnu-package-logo)
	120	(doc-category gnu-package-doc-category)
	121	(doc-summary gnu-package-doc-summary)
	122	(doc-urls gnu-package-doc-urls)
	123	(download-url gnu-package-download-url))
	124
22189ed1	125	(define (official-gnu-packages)
f9bbf2a8 NK	126	"Return a list of records, which are GNU packages."
	127	(define (group-package-fields port state)
	128	;; Return a list of alists. Each alist contains fields of a GNU
	129	;; package.
	130	(let ((line (read-line port))
	131	(field-rx (make-regexp "^([[:graph:]]+): (.*)$"))
	132	(doc-urls-rx (make-regexp "^doc-url: (.*)$"))
	133	(end-rx (make-regexp "^# End. .+Do not remove this line.+")))
	134
	135	(define (match-field str)
	136	;; Packages are separated by empty strings. If STR is an
	137	;; empty string, create a new list to store fields of a
	138	;; different package. Otherwise, match and create a key-value
	139	;; pair.
	140	(match str
	141	(""
	142	(group-package-fields port (cons '() state)))
	143	(str
	144	(cond ((regexp-exec doc-urls-rx str)
	145	=>
	146	(lambda (match)
	147	(if (equal? (assoc-ref (first state) "doc-urls") #f)
	148	(group-package-fields
	149	port (cons (cons (cons "doc-urls"
	150	(list
	151	(match:substring match 1)))
	152	(first state))
	153	(drop state 1)))
	154	(group-package-fields
	155	port (cons (cons (cons "doc-urls"
	156	(cons (match:substring match 1)
	157	(assoc-ref (first state)
	158	"doc-urls")))
	159	(assoc-remove! (first state)
	160	"doc-urls"))
	161	(drop state 1))))))
	162	((regexp-exec field-rx str)
	163	=>
	164	(lambda (match)
	165	(group-package-fields
	166	port (cons (cons (cons (match:substring match 1)
	167	(match:substring match 2))
	168	(first state))
	169	(drop state 1)))))
	170	(else (group-package-fields port state))))))
	171
	172	(if (or (eof-object? line)
	173	(regexp-exec end-rx line)) ; don't include dummy fields
	174	(remove null-list? state)
	175	(match-field line))))
	176
	177	(define (alist->record alist make keys)
	178	;; Apply MAKE, which should be a syntactic constructor, to the
	179	;; values associated with KEYS in ALIST.
	180	(let ((args (map (cut assoc-ref alist <>) keys)))
	181	(apply make args)))
	182
	183	(reverse
	184	(map (lambda (alist)
	185	(alist->record alist
	186	make-gnu-package-descriptor
	187	(list "package" "mundane-name" "copyright-holder"
	188	"savannah" "fsd" "language" "logo"
	189	"doc-category" "doc-summary" "doc-urls"
190	"download-url")))
191	(group-package-fields (http-fetch %package-list-url)
192	'(())))))
22189ed1	193
f9bbf2a8 NK	194	(define (find-packages regexp)
	195	"Find GNU packages which satisfy REGEXP."
	196	(let ((name-rx (make-regexp regexp)))
	197	(filter (lambda (package)
	198	(false-if-exception
	199	(regexp-exec name-rx (gnu-package-name package))))
	200	(official-gnu-packages))))
ef010c0f LC	201
	202	(define gnu-package?
	203	(memoize
	204	(lambda (package)
	205	"Return true if PACKAGE is a GNU package. This procedure may access the
	206	network to check in GNU's database."
	207	;; TODO: Find a way to determine that a package is non-GNU without going
	208	;; through the network.
f9bbf2a8 NK	209	(let ((url (and=> (package-source package) origin-uri))
f9bbf2a8 NK	210	(name (package-name package)))
296540a6	211	(or (and (string? url) (string-prefix? "mirror://gnu" url))
f9bbf2a8	212	(and (member name (map gnu-package-name (official-gnu-packages)))
296540a6	213	#t))))))
ef010c0f	214
98fefb21 LC	215	\f
	216	;;;
	217	;;; Latest release.
	218	;;;
	219
	220	(define (ftp-server/directory project)
	221	"Return the FTP server and directory where PROJECT's tarball are
	222	stored."
	223	(define quirks
	224	'(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp")
	225	("ucommon" "ftp.gnu.org" "/gnu/commoncpp")
	226	("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp")
	227	("libosip2" "ftp.gnu.org" "/gnu/osip")
	228	("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt")
	229	("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error")
	230	("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan")
	231	("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg")
	232	("freefont-ttf" "ftp.gnu.org" "/gnu/freefont")
	233	("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript")
	234	("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
	235	("icecat" "ftp.gnu.org" "/gnu/gnuzilla")
	236	("source-highlight" "ftp.gnu.org" "/gnu/src-highlite")
	237	("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz")))
	238
	239	(match (assoc project quirks)
	240	((_ server directory)
	241	(values server directory))
	242	(_
	243	(values "ftp.gnu.org" (string-append "/gnu/" project)))))
	244
	245	(define (releases project)
	246	"Return the list of releases of PROJECT as a list of release name/directory
	247	pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
	248	;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
	249	(define release-rx
	250	(make-regexp (string-append "^" project
	251	"-([0-9]\|[^-])*(-src)?\\.tar\\.")))
	252
	253	(define alpha-rx
	254	(make-regexp "^.-.[0-9](-\|~)?(alpha\|beta\|rc\|cvs\|svn\|git)-?[0-9\\.]*\\.tar\\."))
	255
	256	(define (sans-extension tarball)
	257	(let ((end (string-contains tarball ".tar")))
	258	(substring tarball 0 end)))
	259
6a917ef7 LC	260	(define (release-file file)
	261	;; Return #f if FILE is not a release tarball, otherwise return
	262	;; PACKAGE-VERSION.
	263	(and (not (string-suffix? ".sig" file))
	264	(regexp-exec release-rx file)
	265	(not (regexp-exec alpha-rx file))
	266	(let ((s (sans-extension file)))
	267	(and (regexp-exec %package-name-rx s) s))))
	268
98fefb21 LC	269	(let-values (((server directory) (ftp-server/directory project)))
	270	(define conn (ftp-open server))
	271
	272	(let loop ((directories (list directory))
	273	(result '()))
6a917ef7 LC	274	(match directories
	275	(()
	276	(ftp-close conn)
	277	result)
	278	((directory rest ...)
	279	(let* ((files (ftp-list conn directory))
	280	(subdirs (filter-map (match-lambda
	281	((name 'directory . _) name)
	282	(_ #f))
	283	files)))
	284	(loop (append (map (cut string-append directory "/" <>)
	285	subdirs)
	286	rest)
	287	(append
	288	;; Filter out signatures, deltas, and files which
	289	;; are potentially not releases of PROJECT--e.g.,
	290	;; in /gnu/guile, filter out guile-oops and
	291	;; guile-www; in mit-scheme, filter out binaries.
	292	(filter-map (match-lambda
	293	((file 'file . _)
	294	(and=> (release-file file)
	295	(cut cons <> directory)))
	296	(_ #f))
	297	files)
	298	result))))))))
98fefb21	299
98fefb21 LC	300	(define (latest-release project)
	301	"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
	302	(let ((releases (releases project)))
	303	(and (not (null? releases))
	304	(fold (lambda (release latest)
0d1e6ce4	305	(if (version>? (car release) (car latest))
98fefb21 LC	306	release
	307	latest))
	308	'("" . "")
	309	releases))))
	310
	311	(define %package-name-rx
	312	;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
	313	;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
	314	(make-regexp "^(.*)-(([0-9]\|\\.)+)(-src)?"))
	315
	316	(define (gnu-package-name->name+version name+version)
	317	"Return the package name and version number extracted from NAME+VERSION."
	318	(let ((match (regexp-exec %package-name-rx name+version)))
	319	(if (not match)
	320	(values name+version #f)
	321	(values (match:substring match 1) (match:substring match 2)))))
	322
	323	;;; gnu-maintenance.scm ends here