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

gnupdate: Handle recursive FTP directory structures; handle funky file names.

Browse Source 
This patch allows projects with per-version sub-directories to be
handled (e.g., MIT Scheme, MyServer, IceCat, etc.)  It also makes sure
alpha releases are discarded (e.g., "gnupg-2.1.0beta3") as well as
unrelated files (e.g., "TeXmacs-600dpi-fonts.tar.gz").

* maintainers/scripts/gnu/gnupdate (ftp-list): Return a list of entries
  where each entry indicates the file type in addition to the file name.
  (releases): Adjust accordingly.  Recurse into sub-directories and
  return a list of name/directory pairs.  Catch `ftp-error' instead
  of everything.
  [release-rx]: Adjust to work with TeXmacs.
  [alpha-rx]: New variable.
  [sans-extension]: New procedure.
  (latest-release): Adjust accordingly.
  (%package-name-rx): New variable.
  (package/version): Use it.
  (packages-to-update): Adjust accordingly.  Use the directory returned
  by `latest-release'.
  [unpack]: New procedure.
  (fetch-gnu): Add a `directory' parameter; use it.

svn path=/nixpkgs/trunk/; revision=26075
This commit is contained in:
Ludovic Courtès 2011-02-23 17:36:15 +00:00
parent ad32df1795
commit 7a99d54ca7
1 changed files with 119 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
maintainers/scripts/gnu/gnupdate
View File

@ -478,8 +478,14 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
(throw 'ftp-error conn "LIST" code)))))
(else
(loop (read-line s)
(let ((file (car (reverse (string-tokenize line)))))
(cons file result)))))))
(match (reverse (string-tokenize line))
((file _ ... permissions)
(let ((type (case (string-ref permissions 0)
((#\d) 'directory)
(else 'file))))
(cons (list file type) result)))
((file _ ...)
(cons (cons file 'file) result))))))))
(lambda ()
(close s)
(let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
@ -597,28 +603,59 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
(or (assoc-ref quirks project) project))
(define (releases project)
;; TODO: Handle project release trees like that of IceCat and MyServer.
"Return the list of releases of PROJECT as a list of release name/directory
pairs. Example: (\"mit-scheme-9.0.1\" . \"/gnu/mit-scheme/stable.pkg/9.0.1\"). "
;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
(define release-rx
(make-regexp (string-append "^" project "-[0-9].*\\.tar\\.")))
(make-regexp (string-append "^" project
"-([0-9]|[^-])*(-src)?\\.tar\\.")))
(catch #t
(lambda ()
(let-values (((server directory) (ftp-server/directory project)))
(let* ((conn (ftp-open server))
(files (ftp-list conn directory)))
(ftp-close conn)
(map (lambda (tarball)
(define alpha-rx
(make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|cvs|svn|git)-?[0-9\\.]*\\.tar\\."))
(define (sans-extension tarball)
(let ((end (string-contains tarball ".tar")))
(substring tarball 0 end)))
(catch 'ftp-error
(lambda ()
(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).
(filter (lambda (file)
;; 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)))
files)))))
(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)))))))
(lambda (key subr message . args)
(format (current-error-port)
"failed to get release list for `~A': ~A ~A~%"
@ -634,53 +671,64 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
(> (strverscmp (string->pointer a) (string->pointer b)) 0))))
(define (latest-release project)
;; Return "FOO-X.Y" or #f.
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
(let ((releases (releases project)))
(and (not (null? releases))
(fold (lambda (release latest)
(if (version-string>? release latest)
(if (version-string>? (car release) (car latest))
release
latest))
""
'("" . "")
releases))))
(define %package-name-rx
;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses
;; "TeXmacs-X.Y-src", the `-src' suffix is allowed.
(make-regexp "^(.*)-(([0-9]|\\.)+)(-src)?"))
(define (package/version name+version)
(let ((hyphen (string-rindex name+version #\-)))
(if (not hyphen)
"Return the package name and version number extracted from NAME+VERSION."
(let ((match (regexp-exec %package-name-rx name+version)))
(if (not match)
(values name+version #f)
(let ((name (substring name+version 0 hyphen))
(version (substring name+version (+ hyphen 1)
(string-length name+version))))
(values name version)))))
(values (match:substring match 1) (match:substring match 2)))))
(define (file-extension file)
(let ((dot (string-rindex file #\.)))
(and dot (substring file (+ 1 dot) (string-length file)))))
(define (packages-to-update gnu-packages)
(define (unpack latest)
(call-with-values (lambda ()
(package/version (car latest)))
(lambda (name version)
(list name version (cdr latest)))))
(fold (lambda (pkg result)
(call-with-package pkg
(lambda (attribute name+version location meta src)
(let-values (((name old-version)
(package/version name+version)))
(let ((latest (latest-release (nixpkgs->gnu-name name))))
(cond ((not latest)
(if (not latest)
(begin
(format #t "~A [unknown latest version]~%"
name+version)
result)
((string=? name+version latest)
(match (unpack latest)
((_ (? (cut string=? old-version <>)) _)
(format #t "~A [up to date]~%" name+version)
result)
(else
(let-values (((project new-version)
(package/version latest))
((old-name old-hash old-urls)
((project new-version directory)
(let-values (((old-name old-hash old-urls)
(src->values src)))
(format #t "~A -> ~A [~A]~%" name+version latest
(format #t "~A -> ~A [~A]~%"
name+version (car latest)
(and (pair? old-urls) (car old-urls)))
(let* ((url (and (pair? old-urls)
(car old-urls)))
(new-hash (fetch-gnu project new-version
(new-hash (fetch-gnu project directory
new-version
(if url
(file-extension url)
"gz"))))
@ -688,14 +736,13 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
old-version old-hash
new-version new-hash
location)
result))))))))))
result)))))))))))
'()
gnu-packages))
(define (fetch-gnu project version archive-type)
(let-values (((server directory)
(ftp-server/directory project)))
(let* ((base (string-append project "-" version ".tar." archive-type))
(define (fetch-gnu project directory version archive-type)
(let* ((server (ftp-server/directory project))
(base (string-append project "-" version ".tar." archive-type))
(url (string-append "ftp://" server "/" directory "/" base))
(sig (string-append base ".sig"))
(sig-url (string-append url ".sig")))
@ -720,7 +767,7 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
(begin
(format (current-error-port)
"no signature for `~a'~%" base)
hash))))))))
hash)))))))
;;;
@ -823,3 +870,7 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
(_ #f)))
updates)
#t))
;;; Local Variables:
;;; eval: (put 'call-with-package 'scheme-indent-function 1)
;;; End: