nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gnu-maintenance: Generalize 'latest-ftp-release'. 

* guix/gnu-maintenance.scm (latest-release): Rename to...
(latest-ftp-release): ... this.  Add #:server and #:directory
parameters.
(latest-release): New procedure.
This commit is contained in:
Ludovic Courtès 2015-12-07 23:18:06 +01:00
parent fba607b129
commit e946f2ec92
1 changed files with 68 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
guix/gnu-maintenance.scm
View File

@ -317,10 +317,14 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\").
files) files)
result)))))))) result))))))))
(define* (latest-release project (define* (latest-ftp-release project
#:key (ftp-open ftp-open) (ftp-close ftp-close)) #:key
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f. Use FTP-OPEN and FTP-CLOSE to (server "ftp.gnu.org")
open (resp. close) FTP connections; this can be useful to reuse connections." (directory (string-append "/gnu/" project))
(ftp-open ftp-open) (ftp-close ftp-close))
"Return an <upstream-source> for the latest release of PROJECT on SERVER
under DIRECTORY, 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) (define (latest a b)
(if (version>? a b) a b)) (if (version>? a b) a b))
@ -335,63 +339,72 @@ open (resp. close) FTP connections; this can be useful to reuse connections."
;; Return #t for patch directory names such as 'bash-4.2-patches'. ;; Return #t for patch directory names such as 'bash-4.2-patches'.
(cut string-suffix? "patches" <>)) (cut string-suffix? "patches" <>))
(let-values (((server directory) (ftp-server/directory project))) (define conn (ftp-open server))
(define conn (ftp-open server))
(define (file->url directory file) (define (file->url directory file)
(string-append "ftp://" server directory "/" file)) (string-append "ftp://" server directory "/" file))
(define (file->source directory file) (define (file->source directory file)
(let ((url (file->url directory file))) (let ((url (file->url directory file)))
(upstream-source (upstream-source
(package project) (package project)
(version (tarball->version file)) (version (tarball->version file))
(urls (list url)) (urls (list url))
(signature-urls (list (string-append url ".sig")))))) (signature-urls (list (string-append url ".sig"))))))
(let loop ((directory directory) (let loop ((directory directory)
(result #f)) (result #f))
(let* ((entries (ftp-list conn directory)) (let* ((entries (ftp-list conn directory))
;; Filter out sub-directories that do not contain digits---e.g., ;; Filter out sub-directories that do not contain digits---e.g.,
;; /gnuzilla/lang and /gnupg/patches. Filter out "w32" ;; /gnuzilla/lang and /gnupg/patches. Filter out "w32"
;; directories as found on ftp.gnutls.org. ;; directories as found on ftp.gnutls.org.
(subdirs (filter-map (match-lambda (subdirs (filter-map (match-lambda
(((? patch-directory-name? dir) (((? patch-directory-name? dir)
'directory . _) 'directory . _)
#f) #f)
(("w32" 'directory . _) (("w32" 'directory . _)
#f) #f)
(((? contains-digit? dir) 'directory . _) (((? contains-digit? dir) 'directory . _)
dir) dir)
(_ #f)) (_ #f))
entries)) entries))
;; Whether or not SUBDIRS is empty, compute the latest releases ;; Whether or not SUBDIRS is empty, compute the latest releases
;; for the current directory. This is necessary for packages ;; for the current directory. This is necessary for packages
;; such as 'sharutils' that have a sub-directory that contains ;; such as 'sharutils' that have a sub-directory that contains
;; only an older release. ;; only an older release.
(releases (filter-map (match-lambda (releases (filter-map (match-lambda
((file 'file . _) ((file 'file . _)
(and (release-file? project file) (and (release-file? project file)
(file->source directory file))) (file->source directory file)))
(_ #f)) (_ #f))
entries))) entries)))
;; Assume that SUBDIRS correspond to versions, and jump into the ;; Assume that SUBDIRS correspond to versions, and jump into the
;; one with the highest version number. ;; one with the highest version number.
(let* ((release (reduce latest-release #f (let* ((release (reduce latest-release #f
(coalesce-sources releases))) (coalesce-sources releases)))
(result (if (and result release) (result (if (and result release)
(latest-release release result) (latest-release release result)
(or release result))) (or release result)))
(target (reduce latest #f subdirs))) (target (reduce latest #f subdirs)))
(if target (if target
(loop (string-append directory "/" target) (loop (string-append directory "/" target)
result) result)
(begin (begin
(ftp-close conn) (ftp-close conn)
result))))))) result))))))
(define (latest-release package . rest)
"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)))
(define (latest-release* package) (define (latest-release* package)
"Like 'latest-release', but ignore FTP errors that might occur when PACKAGE "Like 'latest-release', but ignore FTP errors that might occur when PACKAGE