diff options
author | Ludovic Courtès <ludo@gnu.org> | 2013-03-05 22:31:19 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2013-03-05 22:31:19 +0100 |
commit | 6a917ef7e6a7958a86a280215e1c262bf5b9b259 (patch) | |
tree | 25408907454248fad83bd3cafe00e3610c3d22ee | |
parent | 296540a6dbd594a34e6ea3c223081f123ce30c7a (diff) | |
download | guix-6a917ef7e6a7958a86a280215e1c262bf5b9b259.tar.gz |
gnu-maintenance: Clarify `releases'.
* guix/gnu-maintenance.scm (releases): Change to use `match' and `match-lambda'. Add `release-file' auxiliary function.
-rw-r--r-- | guix/gnu-maintenance.scm | 66 |
1 files changed, 34 insertions, 32 deletions
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 184875300a..cde31aaa7b 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -134,43 +134,45 @@ pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). (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 '())) - (if (null? directories) - (begin - (ftp-close conn) - result) - (let* ((directory (car directories)) - (files (ftp-list conn directory)) - (subdirs (filter-map (lambda (file) - (match file - ((name 'directory . _) name) - (_ #f))) - files))) - (loop (append (map (cut string-append directory "/" <>) - subdirs) - (cdr directories)) - (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 (lambda (file) - (match file - ((file 'file . _) - (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) - (cons s directory))))) - (_ #f))) - files) - 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." |