public/nixpkgs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

gnupdate: Add optional directory argument to `ftp-list'.

Browse Source 
* maintainers/scripts/gnu/gnupdate.scm (ftp-list): Add optional
  DIRECTORY argument.
  (releases): Pass DIRECTORY to `ftp-list'.

svn path=/nixpkgs/trunk/; revision=21715
This commit is contained in:
Ludovic Courtès 2010-05-10 21:26:48 +00:00
parent d8c33c1820
commit 5dd1036a04
1 changed files with 17 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
maintainers/scripts/gnu/gnupdate.scm
View File

@ -360,7 +360,7 @@
(throw 'ftp-error conn "PASV" 227 message))))) (throw 'ftp-error conn "PASV" 227 message)))))
(define (ftp-list conn) (define* (ftp-list conn #:optional directory)
(define (address-with-port sa port) (define (address-with-port sa port)
(let ((fam (sockaddr:fam sa)) (let ((fam (sockaddr:fam sa))
(addr (sockaddr:addr sa))) (addr (sockaddr:addr sa)))
@ -372,6 +372,9 @@
(sockaddr:scopeid sa))) (sockaddr:scopeid sa)))
(else #f)))) (else #f))))
(if directory
(ftp-chdir conn directory))
(let* ((port (ftp-pasv conn)) (let* ((port (ftp-pasv conn))
(ai (ftp-connection-addrinfo conn)) (ai (ftp-connection-addrinfo conn))
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai) (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
@ -514,21 +517,20 @@
(catch #t (catch #t
(lambda () (lambda ()
(let-values (((server directory) (ftp-server/directory project))) (let-values (((server directory) (ftp-server/directory project)))
(let ((conn (ftp-open server))) (let* ((conn (ftp-open server))
(ftp-chdir conn directory) (files (ftp-list conn directory)))
(let ((files (ftp-list conn))) (ftp-close conn)
(ftp-close conn) (map (lambda (tarball)
(map (lambda (tarball) (let ((end (string-contains tarball ".tar")))
(let ((end (string-contains tarball ".tar"))) (substring tarball 0 end)))
(substring tarball 0 end)))
;; Filter out signatures, deltas, and files which are potentially ;; Filter out signatures, deltas, and files which are potentially
;; not releases of PROJECT (e.g., in /gnu/guile, filter out ;; not releases of PROJECT (e.g., in /gnu/guile, filter out
;; guile-oops and guile-www). ;; guile-oops and guile-www).
(filter (lambda (file) (filter (lambda (file)
(and (not (string-suffix? ".sig" file)) (and (not (string-suffix? ".sig" file))
(regexp-exec release-rx file))) (regexp-exec release-rx file)))
files)))))) files)))))
(lambda (key subr message . args) (lambda (key subr message . args)
(format (current-error-port) (format (current-error-port)
"failed to get release list for `~A': ~A ~A~%" "failed to get release list for `~A': ~A ~A~%"