gnupdate: Handle recursive FTP directory structures; handle funky file names.
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:
parent
ad32df1795
commit
7a99d54ca7
|
@ -478,8 +478,14 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
|
||||||
(throw 'ftp-error conn "LIST" code)))))
|
(throw 'ftp-error conn "LIST" code)))))
|
||||||
(else
|
(else
|
||||||
(loop (read-line s)
|
(loop (read-line s)
|
||||||
(let ((file (car (reverse (string-tokenize line)))))
|
(match (reverse (string-tokenize line))
|
||||||
(cons file result)))))))
|
((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 ()
|
(lambda ()
|
||||||
(close s)
|
(close s)
|
||||||
(let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
|
(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))
|
(or (assoc-ref quirks project) project))
|
||||||
|
|
||||||
(define (releases 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.
|
;; TODO: Parse something like fencepost.gnu.org:/gd/gnuorg/packages-ftp.
|
||||||
(define release-rx
|
(define release-rx
|
||||||
(make-regexp (string-append "^" project "-[0-9].*\\.tar\\.")))
|
(make-regexp (string-append "^" project
|
||||||
|
"-([0-9]|[^-])*(-src)?\\.tar\\.")))
|
||||||
|
|
||||||
(catch #t
|
(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 ()
|
(lambda ()
|
||||||
(let-values (((server directory) (ftp-server/directory project)))
|
(let-values (((server directory) (ftp-server/directory project)))
|
||||||
(let* ((conn (ftp-open server))
|
(define conn (ftp-open server))
|
||||||
(files (ftp-list conn directory)))
|
|
||||||
(ftp-close conn)
|
|
||||||
(map (lambda (tarball)
|
|
||||||
(let ((end (string-contains tarball ".tar")))
|
|
||||||
(substring tarball 0 end)))
|
|
||||||
|
|
||||||
;; Filter out signatures, deltas, and files which are potentially
|
(let loop ((directories (list directory))
|
||||||
;; not releases of PROJECT (e.g., in /gnu/guile, filter out
|
(result '()))
|
||||||
;; guile-oops and guile-www).
|
(if (null? directories)
|
||||||
(filter (lambda (file)
|
(begin
|
||||||
(and (not (string-suffix? ".sig" file))
|
(ftp-close conn)
|
||||||
(regexp-exec release-rx file)))
|
result)
|
||||||
files)))))
|
(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)))))))
|
||||||
(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~%"
|
||||||
|
@ -634,53 +671,64 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
|
||||||
(> (strverscmp (string->pointer a) (string->pointer b)) 0))))
|
(> (strverscmp (string->pointer a) (string->pointer b)) 0))))
|
||||||
|
|
||||||
(define (latest-release project)
|
(define (latest-release project)
|
||||||
;; Return "FOO-X.Y" or #f.
|
"Return (\"FOO-X.Y\" . \"/bar/foo\") or #f."
|
||||||
(let ((releases (releases project)))
|
(let ((releases (releases project)))
|
||||||
(and (not (null? releases))
|
(and (not (null? releases))
|
||||||
(fold (lambda (release latest)
|
(fold (lambda (release latest)
|
||||||
(if (version-string>? release latest)
|
(if (version-string>? (car release) (car latest))
|
||||||
release
|
release
|
||||||
latest))
|
latest))
|
||||||
""
|
'("" . "")
|
||||||
releases))))
|
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)
|
(define (package/version name+version)
|
||||||
(let ((hyphen (string-rindex name+version #\-)))
|
"Return the package name and version number extracted from NAME+VERSION."
|
||||||
(if (not hyphen)
|
(let ((match (regexp-exec %package-name-rx name+version)))
|
||||||
|
(if (not match)
|
||||||
(values name+version #f)
|
(values name+version #f)
|
||||||
(let ((name (substring name+version 0 hyphen))
|
(values (match:substring match 1) (match:substring match 2)))))
|
||||||
(version (substring name+version (+ hyphen 1)
|
|
||||||
(string-length name+version))))
|
|
||||||
(values name version)))))
|
|
||||||
|
|
||||||
(define (file-extension file)
|
(define (file-extension file)
|
||||||
(let ((dot (string-rindex file #\.)))
|
(let ((dot (string-rindex file #\.)))
|
||||||
(and dot (substring file (+ 1 dot) (string-length file)))))
|
(and dot (substring file (+ 1 dot) (string-length file)))))
|
||||||
|
|
||||||
(define (packages-to-update gnu-packages)
|
(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)
|
(fold (lambda (pkg result)
|
||||||
(call-with-package pkg
|
(call-with-package pkg
|
||||||
(lambda (attribute name+version location meta src)
|
(lambda (attribute name+version location meta src)
|
||||||
(let-values (((name old-version)
|
(let-values (((name old-version)
|
||||||
(package/version name+version)))
|
(package/version name+version)))
|
||||||
(let ((latest (latest-release (nixpkgs->gnu-name name))))
|
(let ((latest (latest-release (nixpkgs->gnu-name name))))
|
||||||
(cond ((not latest)
|
(if (not latest)
|
||||||
(format #t "~A [unknown latest version]~%"
|
(begin
|
||||||
name+version)
|
(format #t "~A [unknown latest version]~%"
|
||||||
result)
|
name+version)
|
||||||
((string=? name+version latest)
|
result)
|
||||||
|
(match (unpack latest)
|
||||||
|
((_ (? (cut string=? old-version <>)) _)
|
||||||
(format #t "~A [up to date]~%" name+version)
|
(format #t "~A [up to date]~%" name+version)
|
||||||
result)
|
result)
|
||||||
(else
|
((project new-version directory)
|
||||||
(let-values (((project new-version)
|
(let-values (((old-name old-hash old-urls)
|
||||||
(package/version latest))
|
|
||||||
((old-name old-hash old-urls)
|
|
||||||
(src->values src)))
|
(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)))
|
(and (pair? old-urls) (car old-urls)))
|
||||||
(let* ((url (and (pair? old-urls)
|
(let* ((url (and (pair? old-urls)
|
||||||
(car old-urls)))
|
(car old-urls)))
|
||||||
(new-hash (fetch-gnu project new-version
|
(new-hash (fetch-gnu project directory
|
||||||
|
new-version
|
||||||
(if url
|
(if url
|
||||||
(file-extension url)
|
(file-extension url)
|
||||||
"gz"))))
|
"gz"))))
|
||||||
|
@ -688,39 +736,38 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
|
||||||
old-version old-hash
|
old-version old-hash
|
||||||
new-version new-hash
|
new-version new-hash
|
||||||
location)
|
location)
|
||||||
result))))))))))
|
result)))))))))))
|
||||||
'()
|
'()
|
||||||
gnu-packages))
|
gnu-packages))
|
||||||
|
|
||||||
(define (fetch-gnu project version archive-type)
|
(define (fetch-gnu project directory version archive-type)
|
||||||
(let-values (((server directory)
|
(let* ((server (ftp-server/directory project))
|
||||||
(ftp-server/directory project)))
|
(base (string-append project "-" version ".tar." archive-type))
|
||||||
(let* ((base (string-append project "-" version ".tar." archive-type))
|
(url (string-append "ftp://" server "/" directory "/" base))
|
||||||
(url (string-append "ftp://" server "/" directory "/" base))
|
(sig (string-append base ".sig"))
|
||||||
(sig (string-append base ".sig"))
|
(sig-url (string-append url ".sig")))
|
||||||
(sig-url (string-append url ".sig")))
|
(let-values (((hash path) (nix-prefetch-url url)))
|
||||||
(let-values (((hash path) (nix-prefetch-url url)))
|
(pk 'prefetch-url url hash path)
|
||||||
(pk 'prefetch-url url hash path)
|
(and hash path
|
||||||
(and hash path
|
(begin
|
||||||
(begin
|
(false-if-exception (delete-file sig))
|
||||||
(false-if-exception (delete-file sig))
|
(system* "wget" sig-url)
|
||||||
(system* "wget" sig-url)
|
(if (file-exists? sig)
|
||||||
(if (file-exists? sig)
|
(let ((ret (system* "gpg" "--verify" sig path)))
|
||||||
(let ((ret (system* "gpg" "--verify" sig path)))
|
(false-if-exception (delete-file sig))
|
||||||
(false-if-exception (delete-file sig))
|
(if (and ret (= 0 (status:exit-val ret)))
|
||||||
(if (and ret (= 0 (status:exit-val ret)))
|
hash
|
||||||
hash
|
(begin
|
||||||
(begin
|
(format (current-error-port)
|
||||||
(format (current-error-port)
|
"signature verification failed for `~a'~%"
|
||||||
"signature verification failed for `~a'~%"
|
base)
|
||||||
base)
|
(format (current-error-port)
|
||||||
(format (current-error-port)
|
"(could be because the public key is not in your keyring)~%")
|
||||||
"(could be because the public key is not in your keyring)~%")
|
#f)))
|
||||||
#f)))
|
(begin
|
||||||
(begin
|
(format (current-error-port)
|
||||||
(format (current-error-port)
|
"no signature for `~a'~%" base)
|
||||||
"no signature for `~a'~%" base)
|
hash)))))))
|
||||||
hash))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -823,3 +870,7 @@ exec ${GUILE-guile} -L "$PWD" -l "$0" \
|
||||||
(_ #f)))
|
(_ #f)))
|
||||||
updates)
|
updates)
|
||||||
#t))
|
#t))
|
||||||
|
|
||||||
|
;;; Local Variables:
|
||||||
|
;;; eval: (put 'call-with-package 'scheme-indent-function 1)
|
||||||
|
;;; End:
|
||||||
|
|
Loading…
Reference in a new issue