ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 13:58:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu-maintenance: Clarify `releases'.

Browse source 
* guix/gnu-maintenance.scm (releases): Change to use `match' and
  `match-lambda'.  Add `release-file' auxiliary function.
This commit is contained in:
Ludovic Courtès 2013-03-05 22:31:19 +01:00
parent 296540a6db
commit 6a917ef7e6
1 changed files with 34 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
guix/gnu-maintenance.scm
View file

@ -134,43 +134,45 @@ (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 '()))
(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."