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

gnu-maintenance: Clarify `releases'. 

* 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

40
guix/gnu-maintenance.scm
View File

@ -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"))) (let ((end (string-contains tarball ".tar")))
(substring tarball 0 end))) (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))) (let-values (((server directory) (ftp-server/directory project)))
(define conn (ftp-open server)) (define conn (ftp-open server))
(let loop ((directories (list directory)) (let loop ((directories (list directory))
(result '())) (result '()))
(if (null? directories) (match directories
(begin (()
(ftp-close conn) (ftp-close conn)
result) result)
(let* ((directory (car directories)) ((directory rest ...)
(files (ftp-list conn directory)) (let* ((files (ftp-list conn directory))
(subdirs (filter-map (lambda (file) (subdirs (filter-map (match-lambda
(match file
((name 'directory . _) name) ((name 'directory . _) name)
(_ #f))) (_ #f))
files))) files)))
(loop (append (map (cut string-append directory "/" <>) (loop (append (map (cut string-append directory "/" <>)
subdirs) subdirs)
(cdr directories)) rest)
(append (append
;; Filter out signatures, deltas, and files which ;; Filter out signatures, deltas, and files which
;; are potentially not releases of PROJECT--e.g., ;; are potentially not releases of PROJECT--e.g.,
;; in /gnu/guile, filter out guile-oops and ;; in /gnu/guile, filter out guile-oops and
;; guile-www; in mit-scheme, filter out binaries. ;; guile-www; in mit-scheme, filter out binaries.
(filter-map (lambda (file) (filter-map (match-lambda
(match file
((file 'file . _) ((file 'file . _)
(and (not (string-suffix? ".sig" file)) (and=> (release-file file)
(regexp-exec release-rx file) (cut cons <> directory)))
(not (regexp-exec alpha-rx file)) (_ #f))
(let ((s (sans-extension file)))
(and (regexp-exec
%package-name-rx s)
(cons s directory)))))
(_ #f)))
files) files)
result))))))) result))))))))
(define (latest-release project) (define (latest-release project)
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."