03/10: gnu-maintenance: Move FTP directory info to 'properties' fields.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 63e8bb12a46fe6ff493e674fd7ccceb8729c6b47
Author: Ludovic Courtès <address@hidden>
Date:   Thu Apr 14 22:18:56 2016 +0200

    gnu-maintenance: Move FTP directory info to 'properties' fields.
    
    * guix/gnu-maintenance.scm (ftp-server/directory): Rewrite to honor
    PACKAGE's properties.  Remove list of quirks.
    (releases): Add #:server and #:directory parameters.  Remove call
    to 'ftp-server/directory'.
    (latest-release): Likewise.
    (latest-release*): Add call to 'ftp-server/directory'.  Honor
    'upstream-name' property of PACKAGE.
    * gnu/packages/fonts.scm (font-gnu-freefont-ttf): Add 'properties'
    field.
    * gnu/packages/gnupg.scm (libgpg-error, libgcrypt, libassuan):
    (libksba, gnupg): Likewise.
    * gnu/packages/gnuzilla.scm (icecat): Likewise.
    * gnu/packages/package-management.scm (guix-0.10.0): Likewise.
    * gnu/packages/pretty-print.scm (source-highlight): Likewise.
    * gnu/packages/scheme.scm (mit-scheme): Likewise.
    * gnu/packages/telephony.scm (ucommon): Likewise.
    * gnu/packages/tls.scm (gnutls): Likewise.
---
 gnu/packages/fonts.scm              |    4 +-
 gnu/packages/gnupg.scm              |   22 ++++--
 gnu/packages/gnuzilla.scm           |    5 +-
 gnu/packages/package-management.scm |    3 +-
 gnu/packages/pretty-print.scm       |    3 +-
 gnu/packages/scheme.scm             |    5 +-
 gnu/packages/telephony.scm          |    3 +-
 gnu/packages/tls.scm                |    4 +-
 guix/gnu-maintenance.scm            |  155 ++++++++++++++++-------------------
 9 files changed, 105 insertions(+), 99 deletions(-)

diff --git a/gnu/packages/fonts.scm b/gnu/packages/fonts.scm
index 3d75591..aa78926 100644
--- a/gnu/packages/fonts.scm
+++ b/gnu/packages/fonts.scm
@@ -306,7 +306,9 @@ sans-serif designed for on-screen reading.  It is used by 
address@hidden")
      "The GNU Freefont project aims to provide a set of free outline
  (PostScript Type0, TrueType, OpenType...) fonts covering the ISO
 10646/Unicode UCS (Universal Character Set).")
-   (license license:gpl3+)))
+    (license license:gpl3+)
+    (properties '((upstream-name . "freefont")
+                  (ftp-directory . "/gnu/freefont")))))
 
 (define-public font-liberation
   (package
diff --git a/gnu/packages/gnupg.scm b/gnu/packages/gnupg.scm
index 5ed6885..b6c1233 100644
--- a/gnu/packages/gnupg.scm
+++ b/gnu/packages/gnupg.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2013, 2015 Andreas Enge <address@hidden>
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;; Copyright © 2014, 2015, 2016 Mark H Weaver <address@hidden>
@@ -65,7 +65,9 @@
 for all GnuPG components.  Among these are GPG, GPGSM, GPGME,
 GPG-Agent, libgcrypt, Libksba, DirMngr, Pinentry, SmartCard
 Daemon and possibly more in the future.")
-    (license license:lgpl2.0+)))
+    (license license:lgpl2.0+)
+    (properties '((ftp-server . "ftp.gnupg.org")
+                  (ftp-directory . "/gcrypt/libgpg-error")))))
 
 (define-public libgcrypt
   (package
@@ -99,7 +101,9 @@ Daemon and possibly more in the future.")
 standard cryptographic building blocks such as symmetric ciphers, hash
 algorithms, public key algorithms, large integer functions and random number
 generation.")
-    (license license:lgpl2.0+)))
+    (license license:lgpl2.0+)
+    (properties '((ftp-server . "ftp.gnupg.org")
+                  (ftp-directory . "/gcrypt/libgcrypt")))))
 
 (define-public libgcrypt-1.5
   (package (inherit libgcrypt)
@@ -136,7 +140,9 @@ generation.")
 protocol.  This protocol is used for IPC between most newer
 GnuPG components.  Both, server and client side functions are
 provided.")
-    (license license:lgpl2.0+)))
+    (license license:lgpl2.0+)
+    (properties '((ftp-server . "ftp.gnupg.org")
+                  (ftp-directory . "/gcrypt/libassuan")))))
 
 (define-public libksba
   (package
@@ -169,7 +175,9 @@ provided.")
      "KSBA (pronounced Kasbah) is a library to make X.509 certificates
 as well as the CMS easily accessible by other applications.  Both
 specifications are building blocks of S/MIME and TLS.")
-    (license license:gpl3+)))
+    (license license:gpl3+)
+    (properties '((ftp-server . "ftp.gnupg.org")
+                  (ftp-directory . "/gcrypt/libksba")))))
 
 (define-public npth
   (package
@@ -243,7 +251,9 @@ features powerful key management and the ability to access 
public key
 servers.  It includes several libraries: libassuan (IPC between GnuPG
 components), libgpg-error (centralized GnuPG error values), and
 libskba (working with X.509 certificates and CMS data).")
-    (license license:gpl3+)))
+    (license license:gpl3+)
+    (properties '((ftp-server . "ftp.gnupg.org")
+                  (ftp-directory . "/gcrypt/gnupg")))))
 
 (define-public gnupg-2.0
   (package (inherit gnupg)
diff --git a/gnu/packages/gnuzilla.scm b/gnu/packages/gnuzilla.scm
index b2717b8..bf20a4e 100644
--- a/gnu/packages/gnuzilla.scm
+++ b/gnu/packages/gnuzilla.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2015 Andreas Enge <address@hidden>
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2014, 2015, 2016 Mark H Weaver <address@hidden>
 ;;; Copyright © 2015 Sou Bunnbu <address@hidden>
 ;;; Copyright © 2016 Efraim Flashner <address@hidden>
@@ -508,4 +508,5 @@ standards.")
      "IceCat is the GNU version of the Firefox browser.  It is entirely free
 software, which does not recommend non-free plugins and addons.  It also
 features built-in privacy-protecting features.")
-    (license license:mpl2.0))) ; and others, see toolkit/content/license.html
+    (license license:mpl2.0)     ;and others, see toolkit/content/license.html
+    (properties '((ftp-directory . "/gnu/gnuzilla")))))
diff --git a/gnu/packages/package-management.scm 
b/gnu/packages/package-management.scm
index 38c9bdb..46ebde8 100644
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@@ -195,7 +195,8 @@ also a distribution thereof.  It includes a virtual machine 
image.  Besides
 the usual package management features, it also supports transactional
 upgrades and roll-backs, per-user profiles, and much more.  It is based on
 the Nix package manager.")
-    (license gpl3+)))
+    (license gpl3+)
+    (properties '((ftp-server . "alpha.gnu.org")))))
 
 (define guix-devel
   ;; Development version of Guix.
diff --git a/gnu/packages/pretty-print.scm b/gnu/packages/pretty-print.scm
index 7c0f50d..a1692dd 100644
--- a/gnu/packages/pretty-print.scm
+++ b/gnu/packages/pretty-print.scm
@@ -191,7 +191,8 @@ their syntactic role.  It supports over 150 different 
languages and it can
 output to 8 different formats, including HTML, LaTeX and ODF.  It can also
 output to ANSI color escape sequences, so that highlighted source code can be
 seen in a terminal.")
-    (license gpl3+)))
+    (license gpl3+)
+    (properties '((ftp-directory . "/gnu/src-highlite")))))
 
 (define-public astyle
   (package
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index f9537d7..6cf75c2 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <address@hidden>
 ;;; Copyright © 2015 Federico Beffa <address@hidden>
 ;;; Copyright © 2016 Ricardo Wurmus <address@hidden>
@@ -174,7 +174,8 @@
      "GNU/MIT Scheme is an implementation of the Scheme programming
 language.  It provides an interpreter, a compiler and a debugger.  It also
 features an integrated Emacs-like editor and a large runtime library.")
-    (license gpl2+)))
+    (license gpl2+)
+    (properties '((ftp-directory . "/gnu/mit-scheme/stable.pkg")))))
 
 (define-public bigloo
   (package
diff --git a/gnu/packages/telephony.scm b/gnu/packages/telephony.scm
index 76e369a..50a83fb 100644
--- a/gnu/packages/telephony.scm
+++ b/gnu/packages/telephony.scm
@@ -76,7 +76,8 @@ to facilitate using C++ design patterns even for very deeply 
embedded
 applications, such as for systems using uclibc along with posix threading
 support.")
    (license gpl3+)
-   (home-page "http://www.gnu.org/software/commoncpp";)))
+   (home-page "http://www.gnu.org/software/commoncpp";)
+   (properties '((ftp-directory . "/gnu/commoncpp")))))
 
 (define-public ccrtp
   (package
diff --git a/gnu/packages/tls.scm b/gnu/packages/tls.scm
index cb53836..fac26b8 100644
--- a/gnu/packages/tls.scm
+++ b/gnu/packages/tls.scm
@@ -176,7 +176,9 @@ living in the same process.")
 and DTLS protocols.  It is provided in the form of a C library to support the
 protocols, as well as to parse and write X.5009, PKCS 12, OpenPGP and other
 required structures.")
-    (license license:lgpl2.1+)))
+    (license license:lgpl2.1+)
+    (properties '((ftp-server . "ftp.gnutls.org")
+                  (ftp-directory . "/gcrypt/gnutls")))))
 
 (define-public openssl
   (package
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 353892f..8021d99 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -206,34 +206,12 @@ network to check in GNU's database."
 ;;; 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")
-      ("gnutls"       "ftp.gnutls.org" "/gcrypt/gnutls")
-
-      ;; FIXME: ftp.texmacs.org is currently outdated; texmacs.org refers to
-      ;; its own http URL instead.
-      ("TeXmacs"      "ftp.texmacs.org" "/TeXmacs/targz")))
-
-  (match (assoc project quirks)
-    ((_ server directory)
-     (values server directory))
-    (_
-     (values "ftp.gnu.org" (string-append "/gnu/" project)))))
+(define (ftp-server/directory package)
+  "Return the FTP server and directory where PACKAGE's tarball are stored."
+  (values (or (assoc-ref (package-properties package) 'ftp-server)
+              "ftp.gnu.org")
+          (or (assoc-ref (package-properties package) 'ftp-directory)
+              (string-append "/gnu/" (package-name package)))))
 
 (define (sans-extension tarball)
   "Return TARBALL without its .tar.* or .zip extension."
@@ -276,51 +254,53 @@ true."
                 (gnu-package-name->name+version (sans-extension tarball))))
     version))
 
-(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\"). "
+(define* (releases project
+                   #:key
+                   (server "ftp.gnu.org")
+                   (directory (string-append "/gnu/" project)))
+  "Return the list of <upstream-release> of PROJECT as a list of release
+name/directory pairs."
   ;; 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-sources result))
-        ((directory rest ...)
-         (let* ((files   (ftp-list conn directory))
-                (subdirs (filter-map (match-lambda
-                                       ((name 'directory . _) name)
-                                       (_ #f))
-                                     files)))
-           (define (file->url file)
-             (string-append "ftp://"; server directory "/" file))
-
-           (define (file->source file)
-             (let ((url (file->url file)))
-               (upstream-source
-                (package project)
-                (version (tarball->version file))
-                (urls (list url))
-                (signature-urls (list (string-append url ".sig"))))))
-
-           (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? project file)
-                                      (file->source file)))
-                                (_ #f))
-                              files)
-                  result))))))))
+  (define conn (ftp-open server))
+
+  (let loop ((directories (list directory))
+             (result      '()))
+    (match directories
+      (()
+       (ftp-close conn)
+       (coalesce-sources result))
+      ((directory rest ...)
+       (let* ((files   (ftp-list conn directory))
+              (subdirs (filter-map (match-lambda
+                                     ((name 'directory . _) name)
+                                     (_ #f))
+                                   files)))
+         (define (file->url file)
+           (string-append "ftp://"; server directory "/" file))
+
+         (define (file->source file)
+           (let ((url (file->url file)))
+             (upstream-source
+              (package project)
+              (version (tarball->version file))
+              (urls (list url))
+              (signature-urls (list (string-append url ".sig"))))))
+
+         (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? project file)
+                                    (file->source file)))
+                              (_ #f))
+                            files)
+                result)))))))
 
 (define* (latest-ftp-release project
                              #:key
@@ -412,15 +392,15 @@ return the corresponding signature URL, or #f it 
signatures are unavailable."
               (ftp-close conn)
               result))))))
 
-(define (latest-release package . rest)
+(define* (latest-release package
+                         #:key
+                         (server "ftp.gnu.org")
+                         (directory (string-append "/gnu/" package)))
   "Return the <upstream-source> for the latest version of PACKAGE or #f.
-PACKAGE is the name of a GNU package.  This procedure automatically uses the
-right FTP server and directory for PACKAGE."
-  (let-values (((server directory) (ftp-server/directory package)))
-    (apply latest-ftp-release package
-           #:server server
-           #:directory directory
-           rest)))
+PACKAGE must be the canonical name of a GNU package."
+  (latest-ftp-release package
+                      #:server server
+                      #:directory directory))
 
 (define-syntax-rule (false-if-ftp-error exp)
   "Return #f if an FTP error is raise while evaluating EXP; return the result
@@ -435,10 +415,17 @@ of EXP otherwise."
       #f)))
 
 (define (latest-release* package)
-  "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE
-is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that
-name (this is the case for \"emacs-auctex\", for instance.)"
-  (false-if-ftp-error (latest-release (package-name package))))
+  "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP
+errors that might occur when PACKAGE is not actually a GNU package, or not
+hosted on ftp.gnu.org, or not under that name (this is the case for
+\"emacs-auctex\", for instance.)"
+  (let-values (((server directory)
+                (ftp-server/directory package)))
+    (let ((name (or (assoc-ref (package-properties package) 'upstream-name)
+                    (package-name package))))
+      (false-if-ftp-error (latest-release name
+                                          #:server server
+                                          #:directory directory)))))
 
 (define %package-name-rx
   ;; Regexp for a package name, e.g., "foo-X.Y".  Since TeXmacs uses