mirror of
https://github.com/ilyakooo0/nixpkgs.git
synced 2024-12-26 04:43:09 +03:00
gnupdate: Turn into a module.
* maintainers/scripts/gnu/gnupdate.scm: Rename to... * maintainers/scripts/gnu/gnupdate: ... this. Use `define-module' and the orthodox way of doing things. (main): Rename to... (gnupdate): ... this. svn path=/nixpkgs/trunk/; revision=22466
This commit is contained in:
Ludovic Courtès
parent
c3484e59e9
commit
c83cb10f2b
@ -1,4 +1,836 @@
|
||||
#!/bin/sh
|
||||
# This is actually -*- mode: scheme; coding: utf-8; -*- text.
|
||||
main='(module-ref (resolve-module '\''(gnupdate)) '\'gnupdate')'
|
||||
exec ${GUILE-guile} -L "$PWD" -l "$0" \
|
||||
-c "(apply $main (command-line))" "$@"
|
||||
!#
|
||||
;;; GNUpdate -- Update GNU packages in Nixpkgs.
|
||||
;;; Copyright (C) 2010 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation, either version 3 of the License, or
|
||||
;;; (at your option) any later version.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
exec "${GUILE:-guile}" $GUILE_FLAGS -L . -l gnupdate.scm \
|
||||
-e '(apply main (cdr (command-line)))' -- "$@"
|
||||
(cond-expand (guile-2 #t)
|
||||
(else (error "GNU Guile 2.0 is required")))
|
||||
|
||||
(define-module (gnupdate)
|
||||
#:use-module (sxml ssax)
|
||||
#:use-module (ice-9 popen)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (system foreign)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:export (gnupdate))
|
||||
|
||||
|
||||
;;;
|
||||
;;; SNix.
|
||||
;;;
|
||||
|
||||
(define-record-type <location>
|
||||
(make-location file line column)
|
||||
location?
|
||||
(file location-file)
|
||||
(line location-line)
|
||||
(column location-column))
|
||||
|
||||
(define (->loc line column path)
|
||||
(and line column path
|
||||
(make-location path (string->number line) (string->number column))))
|
||||
|
||||
;; XXX: Hack to add missing exports from `(sxml ssax)' as of 1.9.10.
|
||||
(let ((ssax (resolve-module '(sxml ssax))))
|
||||
(for-each (lambda (sym)
|
||||
(module-add! (current-module) sym
|
||||
(module-variable ssax sym)))
|
||||
'(ssax:warn ssax:skip-pi nl)))
|
||||
|
||||
;; Nix object types visible in the XML output of `nix-instantiate' and
|
||||
;; mapping to S-expressions (we map to sexps, not records, so that we
|
||||
;; can do pattern matching):
|
||||
;;
|
||||
;; at (at varpat attrspat)
|
||||
;; attr (attribute loc name value)
|
||||
;; attrs (attribute-set attributes)
|
||||
;; attrspat (attribute-set-pattern patterns)
|
||||
;; bool #f|#t
|
||||
;; derivation (derivation drv-path out-path attributes)
|
||||
;; ellipsis '...
|
||||
;; expr (snix loc body ...)
|
||||
;; function (function loc at|attrspat|varpat)
|
||||
;; int int
|
||||
;; list list
|
||||
;; null 'null
|
||||
;; path string
|
||||
;; string string
|
||||
;; unevaluated 'unevaluated
|
||||
;; varpat (varpat name)
|
||||
;;
|
||||
;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
|
||||
;; however, handling `repeated' nodes makes it impossible to do anything
|
||||
;; lazily because the whole SXML tree has to be traversed to maintain the
|
||||
;; list of known derivations.
|
||||
|
||||
(define (xml-element->snix elem attributes body derivations)
|
||||
;; Return an SNix element corresponding to XML element ELEM.
|
||||
|
||||
(define (loc)
|
||||
(->loc (assq-ref attributes 'line)
|
||||
(assq-ref attributes 'column)
|
||||
(assq-ref attributes 'path)))
|
||||
|
||||
(case elem
|
||||
((at)
|
||||
(values `(at ,(car body) ,(cadr body)) derivations))
|
||||
((attr)
|
||||
(let ((name (assq-ref attributes 'name)))
|
||||
(cond ((null? body)
|
||||
(values `(attribute-pattern ,name) derivations))
|
||||
((and (pair? body) (null? (cdr body)))
|
||||
(values `(attribute ,(loc) ,name ,(car body))
|
||||
derivations))
|
||||
(else
|
||||
(error "invalid attribute body" name (loc) body)))))
|
||||
((attrs)
|
||||
(values `(attribute-set ,(reverse body)) derivations))
|
||||
((attrspat)
|
||||
(values `(attribute-set-pattern ,body) derivations))
|
||||
((bool)
|
||||
(values (string-ci=? "true" (assq-ref attributes 'value))
|
||||
derivations))
|
||||
((derivation)
|
||||
(let ((drv-path (assq-ref attributes 'drvPath))
|
||||
(out-path (assq-ref attributes 'outPath)))
|
||||
(if (equal? body '(repeated))
|
||||
(let ((body (vhash-assoc drv-path derivations)))
|
||||
(if (pair? body)
|
||||
(values `(derivation ,drv-path ,out-path ,(cdr body))
|
||||
derivations)
|
||||
(error "no previous occurrence of derivation"
|
||||
drv-path)))
|
||||
(values `(derivation ,drv-path ,out-path ,body)
|
||||
(vhash-cons drv-path body derivations)))))
|
||||
((ellipsis)
|
||||
(values '... derivations))
|
||||
((expr)
|
||||
(values `(snix ,(loc) ,@body) derivations))
|
||||
((function)
|
||||
(values `(function ,(loc) ,body) derivations))
|
||||
((int)
|
||||
(values (string->number (assq-ref attributes 'value))
|
||||
derivations))
|
||||
((list)
|
||||
(values body derivations))
|
||||
((null)
|
||||
(values 'null derivations))
|
||||
((path)
|
||||
(values (assq-ref attributes 'value) derivations))
|
||||
((repeated)
|
||||
(values 'repeated derivations))
|
||||
((string)
|
||||
(values (assq-ref attributes 'value) derivations))
|
||||
((unevaluated)
|
||||
(values 'unevaluated derivations))
|
||||
((varpat)
|
||||
(values `(varpat ,(assq-ref attributes 'name)) derivations))
|
||||
(else (error "unhandled Nix XML element" elem))))
|
||||
|
||||
(define xml->snix
|
||||
;; Return the SNix represention of TREE, an SXML tree as returned by
|
||||
;; parsing the XML output of `nix-instantiate' on Nixpkgs.
|
||||
(let ((parse
|
||||
(ssax:make-parser NEW-LEVEL-SEED
|
||||
(lambda (elem-gi attributes namespaces expected-content
|
||||
seed)
|
||||
(cons '() (cdr seed)))
|
||||
|
||||
FINISH-ELEMENT
|
||||
(lambda (elem-gi attributes namespaces parent-seed
|
||||
seed)
|
||||
(let ((snix (car seed))
|
||||
(derivations (cdr seed)))
|
||||
(let-values (((snix derivations)
|
||||
(xml-element->snix elem-gi
|
||||
attributes
|
||||
snix
|
||||
derivations)))
|
||||
(cons (cons snix (car parent-seed))
|
||||
derivations))))
|
||||
|
||||
CHAR-DATA-HANDLER
|
||||
(lambda (string1 string2 seed)
|
||||
;; Discard inter-node strings, which are blanks.
|
||||
seed))))
|
||||
(lambda (port)
|
||||
;; Discard the second value returned by the parser (the derivation
|
||||
;; vhash).
|
||||
(caar (parse port (cons '() vlist-null))))))
|
||||
|
||||
(define (call-with-package snix proc)
|
||||
(match snix
|
||||
(('attribute _ (and attribute-name (? string?))
|
||||
('derivation _ _ body))
|
||||
;; Ugly pattern matching.
|
||||
(let ((meta
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "meta" ('attribute-set metas)) metas)
|
||||
(_ #f)))
|
||||
body))
|
||||
(package-name
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "name" (and name (? string?)))
|
||||
name)
|
||||
(_ #f)))
|
||||
body))
|
||||
(location
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute loc "name" (? string?))
|
||||
loc)
|
||||
(_ #f)))
|
||||
body))
|
||||
(src
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "src" src)
|
||||
src)
|
||||
(_ #f)))
|
||||
body)))
|
||||
(proc attribute-name package-name location meta src)))))
|
||||
|
||||
(define (call-with-src snix proc)
|
||||
;; Assume SNIX contains the SNix expression for the value of an `src'
|
||||
;; attribute, as returned by `call-with-package', and call PROC with the
|
||||
;; relevant SRC information, or #f if SNIX doesn't match.
|
||||
(match snix
|
||||
(('derivation _ _ body)
|
||||
(let ((name
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "name" (and name (? string?)))
|
||||
name)
|
||||
(_ #f)))
|
||||
body))
|
||||
(output-hash
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "outputHash" (and hash (? string?)))
|
||||
hash)
|
||||
(_ #f)))
|
||||
body))
|
||||
(urls
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "urls" (and urls (? pair?)))
|
||||
urls)
|
||||
(_ #f)))
|
||||
body)))
|
||||
(proc name output-hash urls)))
|
||||
(_ (proc #f #f #f))))
|
||||
|
||||
(define (src->values snix)
|
||||
(call-with-src snix values))
|
||||
|
||||
(define (attribute-value attribute)
|
||||
;; Return the value of ATTRIBUTE.
|
||||
(match attribute
|
||||
(('attribute _ _ value) value)))
|
||||
|
||||
(define (derivation-source derivation)
|
||||
;; Return the "src" attribute of DERIVATION or #f if not found.
|
||||
(match derivation
|
||||
(('derivation _ _ (attributes ...))
|
||||
(find-attribute-by-name "src" attributes))))
|
||||
|
||||
(define (derivation-output-path derivation)
|
||||
;; Return the output path of DERIVATION.
|
||||
(match derivation
|
||||
(('derivation _ out-path _)
|
||||
out-path)
|
||||
(_ #f)))
|
||||
|
||||
(define (source-output-path src)
|
||||
;; Return the output path of SRC, the "src" attribute of a derivation.
|
||||
(derivation-output-path (attribute-value src)))
|
||||
|
||||
(define (derivation-source-output-path derivation)
|
||||
;; Return the output path of the "src" attribute of DERIVATION or #f if
|
||||
;; DERIVATION lacks an "src" attribute.
|
||||
(and=> (derivation-source derivation) source-output-path))
|
||||
|
||||
(define (open-nixpkgs nixpkgs)
|
||||
(let ((script (string-append nixpkgs
|
||||
"/maintainers/scripts/eval-release.nix")))
|
||||
(open-pipe* OPEN_READ "nix-instantiate"
|
||||
"--strict" "--eval-only" "--xml"
|
||||
script)))
|
||||
|
||||
(define (nix-prefetch-url url)
|
||||
;; Download URL in the Nix store and return the base32-encoded SHA256 hash
|
||||
;; of the file at URL
|
||||
(let* ((pipe (open-pipe* OPEN_READ "nix-prefetch-url" url))
|
||||
(hash (read-line pipe)))
|
||||
(close-pipe pipe)
|
||||
(if (eof-object? hash)
|
||||
(values #f #f)
|
||||
(let* ((pipe (open-pipe* OPEN_READ "nix-store" "--print-fixed-path"
|
||||
"sha256" hash (basename url)))
|
||||
(path (read-line pipe)))
|
||||
(if (eof-object? path)
|
||||
(values #f #f)
|
||||
(values (string-trim-both hash) (string-trim-both path)))))))
|
||||
|
||||
(define (update-nix-expression file
|
||||
old-version old-hash
|
||||
new-version new-hash)
|
||||
;; Modify FILE in-place. Ugly: we call out to sed(1).
|
||||
(let ((cmd (format #f "sed -i \"~a\" -e 's/~A/~a/g ; s/~A/~A/g'"
|
||||
file
|
||||
(regexp-quote old-version) new-version
|
||||
old-hash
|
||||
(or new-hash "new hash not available, check the log"))))
|
||||
(format #t "running `~A'...~%" cmd)
|
||||
(system cmd)))
|
||||
|
||||
(define (find-attribute-by-name name attributes)
|
||||
;; Return attribute NAME in ATTRIBUTES, a list of SNix attributes, or #f if
|
||||
;; NAME cannot be found.
|
||||
(find (lambda (a)
|
||||
(match a
|
||||
(('attribute _ (? (cut string=? <> name)) _)
|
||||
a)
|
||||
(_ #f)))
|
||||
attributes))
|
||||
|
||||
(define (find-package-by-attribute-name name packages)
|
||||
;; Return the package bound to attribute NAME in PACKAGES, a list of
|
||||
;; packages (SNix attributes), or #f if NAME cannot be found.
|
||||
(find (lambda (package)
|
||||
(match package
|
||||
(('attribute _ (? (cut string=? <> name))
|
||||
('derivation _ _ _))
|
||||
package)
|
||||
(_ #f)))
|
||||
packages))
|
||||
|
||||
(define (stdenv-package packages)
|
||||
;; Return the `stdenv' package from PACKAGES, a list of SNix attributes.
|
||||
(find-package-by-attribute-name "stdenv" packages))
|
||||
|
||||
(define (package-requisites package)
|
||||
;; Return the list of derivations required to build PACKAGE (including that
|
||||
;; of PACKAGE) by recurring into its derivation attributes.
|
||||
(let loop ((snix package)
|
||||
(result '()))
|
||||
(match snix
|
||||
(('attribute _ _ body)
|
||||
(loop body result))
|
||||
(('derivation _ out-path body)
|
||||
(if (any (lambda (d)
|
||||
(match d
|
||||
(('derivation _ (? (cut string=? out-path <>)) _) #t)
|
||||
(_ #f)))
|
||||
result)
|
||||
result
|
||||
(loop body (cons snix result))))
|
||||
((things ...)
|
||||
(fold loop result things))
|
||||
(_ result))))
|
||||
|
||||
(define (package-source-output-path package)
|
||||
;; Return the output path of the "src" derivation of PACKAGE.
|
||||
(derivation-source-output-path (attribute-value package)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; FTP client.
|
||||
;;;
|
||||
|
||||
(define-record-type <ftp-connection>
|
||||
(%make-ftp-connection socket addrinfo)
|
||||
ftp-connection?
|
||||
(socket ftp-connection-socket)
|
||||
(addrinfo ftp-connection-addrinfo))
|
||||
|
||||
(define %ftp-ready-rx
|
||||
(make-regexp "^([0-9]{3}) (.+)$"))
|
||||
|
||||
(define (%ftp-listen port)
|
||||
(let loop ((line (read-line port)))
|
||||
(cond ((eof-object? line) (values line #f))
|
||||
((regexp-exec %ftp-ready-rx line)
|
||||
=>
|
||||
(lambda (match)
|
||||
(values (string->number (match:substring match 1))
|
||||
(match:substring match 2))))
|
||||
(else
|
||||
(loop (read-line port))))))
|
||||
|
||||
(define (%ftp-command command expected-code port)
|
||||
(format port "~A~A~A" command (string #\return) (string #\newline))
|
||||
(let-values (((code message) (%ftp-listen port)))
|
||||
(if (eqv? code expected-code)
|
||||
message
|
||||
(throw 'ftp-error port command code message))))
|
||||
|
||||
(define (%ftp-login user pass port)
|
||||
(let ((command (string-append "USER " user (string #\newline))))
|
||||
(display command port)
|
||||
(let-values (((code message) (%ftp-listen port)))
|
||||
(case code
|
||||
((230) #t)
|
||||
((331) (%ftp-command (string-append "PASS " pass) 230 port))
|
||||
(else (throw 'ftp-error port command code message))))))
|
||||
|
||||
(define (ftp-open host)
|
||||
(catch 'getaddrinfo-error
|
||||
(lambda ()
|
||||
(let* ((ai (car (getaddrinfo host "ftp")))
|
||||
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
|
||||
(addrinfo:protocol ai))))
|
||||
(connect s (addrinfo:addr ai))
|
||||
(setvbuf s _IOLBF)
|
||||
(let-values (((code message) (%ftp-listen s)))
|
||||
(if (eqv? code 220)
|
||||
(begin
|
||||
;(%ftp-command "OPTS UTF8 ON" 200 s)
|
||||
(%ftp-login "anonymous" "ludo@example.com" s)
|
||||
(%make-ftp-connection s ai))
|
||||
(begin
|
||||
(format (current-error-port) "FTP to `~a' failed: ~A: ~A~%"
|
||||
host code message)
|
||||
(close s)
|
||||
#f)))))
|
||||
(lambda (key errcode)
|
||||
(format (current-error-port) "failed to resolve `~a': ~a~%"
|
||||
host (gai-strerror errcode))
|
||||
#f)))
|
||||
|
||||
(define (ftp-close conn)
|
||||
(close (ftp-connection-socket conn)))
|
||||
|
||||
(define (ftp-chdir conn dir)
|
||||
(%ftp-command (string-append "CWD " dir) 250
|
||||
(ftp-connection-socket conn)))
|
||||
|
||||
(define (ftp-pasv conn)
|
||||
(define %pasv-rx
|
||||
(make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
|
||||
|
||||
(let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
|
||||
(cond ((regexp-exec %pasv-rx message)
|
||||
=>
|
||||
(lambda (match)
|
||||
(+ (* (string->number (match:substring match 5)) 256)
|
||||
(string->number (match:substring match 6)))))
|
||||
(else
|
||||
(throw 'ftp-error conn "PASV" 227 message)))))
|
||||
|
||||
|
||||
(define* (ftp-list conn #:optional directory)
|
||||
(define (address-with-port sa port)
|
||||
(let ((fam (sockaddr:fam sa))
|
||||
(addr (sockaddr:addr sa)))
|
||||
(cond ((= fam AF_INET)
|
||||
(make-socket-address fam addr port))
|
||||
((= fam AF_INET6)
|
||||
(make-socket-address fam addr port
|
||||
(sockaddr:flowinfo sa)
|
||||
(sockaddr:scopeid sa)))
|
||||
(else #f))))
|
||||
|
||||
(if directory
|
||||
(ftp-chdir conn directory))
|
||||
|
||||
(let* ((port (ftp-pasv conn))
|
||||
(ai (ftp-connection-addrinfo conn))
|
||||
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
|
||||
(addrinfo:protocol ai))))
|
||||
(connect s (address-with-port (addrinfo:addr ai) port))
|
||||
(setvbuf s _IOLBF)
|
||||
|
||||
(dynamic-wind
|
||||
(lambda () #t)
|
||||
(lambda ()
|
||||
(%ftp-command "LIST" 150 (ftp-connection-socket conn))
|
||||
|
||||
(let loop ((line (read-line s))
|
||||
(result '()))
|
||||
(cond ((eof-object? line) (reverse result))
|
||||
((regexp-exec %ftp-ready-rx line)
|
||||
=>
|
||||
(lambda (match)
|
||||
(let ((code (string->number (match:substring match 1))))
|
||||
(if (= 126 code)
|
||||
(reverse result)
|
||||
(throw 'ftp-error conn "LIST" code)))))
|
||||
(else
|
||||
(loop (read-line s)
|
||||
(let ((file (car (reverse (string-tokenize line)))))
|
||||
(cons file result)))))))
|
||||
(lambda ()
|
||||
(close s)
|
||||
(let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
|
||||
(or (eqv? code 226)
|
||||
(throw 'ftp-error conn "LIST" code message)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; GNU.
|
||||
;;;
|
||||
|
||||
(define %ignored-package-attributes
|
||||
;; Attribute name of packages to be ignored.
|
||||
'("bash" "bashReal" "bashInteractive" ;; the full versioned name is incorrect
|
||||
"autoconf213"
|
||||
"automake17x"
|
||||
"automake19x"
|
||||
"automake110x"
|
||||
"automake" ;; = 1.10.x
|
||||
"bison1875"
|
||||
"bison23"
|
||||
"bison" ;; = 2.3
|
||||
"emacs22"
|
||||
"emacsSnapshot"
|
||||
"gcc295"
|
||||
"gcc33"
|
||||
"gcc34"
|
||||
"gcc40"
|
||||
"gcc41"
|
||||
"gcc42"
|
||||
"gcc43"
|
||||
"gcc44"
|
||||
"gcc45"
|
||||
"glibc25"
|
||||
"glibc27"
|
||||
"glibc29"
|
||||
"guile_1_9"
|
||||
))
|
||||
|
||||
(define (gnu? package)
|
||||
;; Return true if PACKAGE (a snix expression) is a GNU package (according
|
||||
;; to a simple heuristic.) Otherwise return #f.
|
||||
(match package
|
||||
(('attribute _ _ ('derivation _ _ body))
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "meta" ('attribute-set metas))
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "description" value)
|
||||
(string-prefix? "GNU" value))
|
||||
(('attribute _ "homepage" value)
|
||||
(string-contains value "www.gnu.org"))
|
||||
(_ #f)))
|
||||
metas))
|
||||
(_ #f)))
|
||||
body))
|
||||
(_ #f)))
|
||||
|
||||
(define (gnu-packages packages)
|
||||
(fold (lambda (package gnu)
|
||||
(match package
|
||||
(('attribute _ "emacs23Packages" emacs-packages)
|
||||
;; XXX: Should prepend `emacs23Packages.' to attribute names.
|
||||
(append (gnu-packages emacs-packages) gnu))
|
||||
(('attribute _ attribute-name ('derivation _ _ body))
|
||||
(if (member attribute-name %ignored-package-attributes)
|
||||
gnu
|
||||
(if (gnu? package)
|
||||
(cons package gnu)
|
||||
gnu)))
|
||||
(_ gnu)))
|
||||
'()
|
||||
packages))
|
||||
|
||||
(define (ftp-server/directory project)
|
||||
(define quirks
|
||||
'(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp" #f)
|
||||
("libgcrypt" "ftp.gnupg.org" "/gcrypt" #t)
|
||||
("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t)
|
||||
("gnupg" "ftp.gnupg.org" "/gcrypt" #t)
|
||||
("gnu-ghostscript" "ftp.gnu.org" "/ghostscript" #f)
|
||||
("grub" "alpha.gnu.org" "/gnu" #t)
|
||||
("GNUnet" "ftp.gnu.org" "/gnu/gnunet" #f)
|
||||
("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
|
||||
("icecat" "ftp.gnu.org" "/gnu/gnuzilla" #f)
|
||||
("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz" #f)))
|
||||
|
||||
(let ((quirk (assoc project quirks)))
|
||||
(match quirk
|
||||
((_ server directory subdir?)
|
||||
(values server (if (not subdir?)
|
||||
directory
|
||||
(string-append directory "/" project))))
|
||||
(_
|
||||
(values "ftp.gnu.org" (string-append "/gnu/" project))))))
|
||||
|
||||
(define (nixpkgs->gnu-name project)
|
||||
(define quirks
|
||||
'(("gcc-wrapper" . "gcc")
|
||||
("ghostscript" . "gnu-ghostscript") ;; ../ghostscript/gnu-ghoscript-X.Y.tar.gz
|
||||
("gnum4" . "m4")
|
||||
("gnugrep" . "grep")
|
||||
("gnused" . "sed")
|
||||
("gnutar" . "tar")
|
||||
("gnunet" . "GNUnet") ;; ftp.gnu.org/gnu/gnunet/GNUnet-x.y.tar.gz
|
||||
("mitscheme" . "mit-scheme")
|
||||
("texmacs" . "TeXmacs")))
|
||||
|
||||
(or (assoc-ref quirks project) project))
|
||||
|
||||
(define (releases project)
|
||||
;; TODO: Handle project release trees like that of IceCat and MyServer.
|
||||
(define release-rx
|
||||
(make-regexp (string-append "^" project "-[0-9].*\\.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)
|
||||
(let ((end (string-contains tarball ".tar")))
|
||||
(substring tarball 0 end)))
|
||||
|
||||
;; 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)
|
||||
(and (not (string-suffix? ".sig" file))
|
||||
(regexp-exec release-rx file)))
|
||||
files)))))
|
||||
(lambda (key subr message . args)
|
||||
(format (current-error-port)
|
||||
"failed to get release list for `~A': ~A ~A~%"
|
||||
project message args)
|
||||
'())))
|
||||
|
||||
(define version-string>?
|
||||
(let ((strverscmp
|
||||
(let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
|
||||
(error "could not find `strverscmp' (from GNU libc)"))))
|
||||
(make-foreign-function int sym (list '* '*))))
|
||||
(string->null-terminated-utf8
|
||||
(lambda (s)
|
||||
(let* ((utf8 (string->utf8 s))
|
||||
(len (bytevector-length utf8))
|
||||
(nts (make-bytevector (+ len 1))))
|
||||
(bytevector-copy! utf8 0 nts 0 len)
|
||||
(bytevector-u8-set! nts len 0)
|
||||
nts))))
|
||||
(lambda (a b)
|
||||
(let ((a (bytevector->foreign (string->null-terminated-utf8 a)))
|
||||
(b (bytevector->foreign (string->null-terminated-utf8 b))))
|
||||
(> (strverscmp a b) 0)))))
|
||||
|
||||
(define (latest-release project)
|
||||
;; Return "FOO-X.Y" or #f.
|
||||
(let ((releases (releases project)))
|
||||
(and (not (null? releases))
|
||||
(fold (lambda (release latest)
|
||||
(if (version-string>? release latest)
|
||||
release
|
||||
latest))
|
||||
""
|
||||
releases))))
|
||||
|
||||
(define (package/version name+version)
|
||||
(let ((hyphen (string-rindex name+version #\-)))
|
||||
(if (not hyphen)
|
||||
(values name+version #f)
|
||||
(let ((name (substring name+version 0 hyphen))
|
||||
(version (substring name+version (+ hyphen 1)
|
||||
(string-length name+version))))
|
||||
(values name version)))))
|
||||
|
||||
(define (file-extension file)
|
||||
(let ((dot (string-rindex file #\.)))
|
||||
(and dot (substring file (+ 1 dot) (string-length file)))))
|
||||
|
||||
(define (packages-to-update gnu-packages)
|
||||
(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)
|
||||
(format #t "~A [unknown latest version]~%"
|
||||
name+version)
|
||||
result)
|
||||
((string=? name+version latest)
|
||||
(format #t "~A [up to date]~%" name+version)
|
||||
result)
|
||||
(else
|
||||
(let-values (((project new-version)
|
||||
(package/version latest))
|
||||
((old-name old-hash old-urls)
|
||||
(src->values src)))
|
||||
(format #t "~A -> ~A [~A]~%" name+version latest
|
||||
(and (pair? old-urls) (car old-urls)))
|
||||
(let* ((url (and (pair? old-urls)
|
||||
(car old-urls)))
|
||||
(new-hash (fetch-gnu project new-version
|
||||
(if url
|
||||
(file-extension url)
|
||||
"gz"))))
|
||||
(cons (list name attribute
|
||||
old-version old-hash
|
||||
new-version new-hash
|
||||
location)
|
||||
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))
|
||||
(url (string-append "ftp://" server "/" directory "/" base))
|
||||
(sig (string-append base ".sig"))
|
||||
(sig-url (string-append url ".sig")))
|
||||
(let-values (((hash path) (nix-prefetch-url url)))
|
||||
(pk 'prefetch-url url hash path)
|
||||
(and hash path
|
||||
(begin
|
||||
(false-if-exception (delete-file sig))
|
||||
(system* "wget" sig-url)
|
||||
(if (file-exists? sig)
|
||||
(let ((ret (system* "gpg" "--verify" sig path)))
|
||||
(false-if-exception (delete-file sig))
|
||||
(if (and ret (= 0 (status:exit-val ret)))
|
||||
hash
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"signature verification failed for `~a'~%"
|
||||
base)
|
||||
(format (current-error-port)
|
||||
"(could be because the public key is not in your keyring)~%")
|
||||
#f)))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"no signature for `~a'~%" base)
|
||||
hash))))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Main program.
|
||||
;;;
|
||||
|
||||
(define %options
|
||||
;; Specifications of the command-line options.
|
||||
(list (option '(#\h "help") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(format #t "Usage: gnupdate [OPTIONS...]~%")
|
||||
(format #t "GNUpdate -- update Nix expressions of GNU packages in Nixpkgs~%")
|
||||
(format #t "~%")
|
||||
(format #t " -x, --xml=FILE Read XML output of `nix-instantiate'~%")
|
||||
(format #t " from FILE.~%")
|
||||
(format #t " -s, --select=SET Update only packages from SET, which may~%")
|
||||
(format #t " be either `all',`stdenv', or `non-stdenv'.~%")
|
||||
(format #t " -d, --dry-run Don't actually update Nix expressions~%")
|
||||
(format #t " -h, --help Give this help list.~%~%")
|
||||
(format #t "Report bugs to <ludo@gnu.org>~%")
|
||||
(exit 0)))
|
||||
(option '(#\s "select") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(cond ((string-ci=? arg "stdenv")
|
||||
(alist-cons 'filter 'stdenv result))
|
||||
((string-ci=? arg "non-stdenv")
|
||||
(alist-cons 'filter 'non-stdenv result))
|
||||
((string-ci=? arg "all")
|
||||
(alist-cons 'filter #f result))
|
||||
(else
|
||||
(format (current-error-port)
|
||||
"~A: unrecognized selection type~%"
|
||||
arg)
|
||||
(exit 1)))))
|
||||
|
||||
(option '(#\d "dry-run") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'dry-run #t result)))
|
||||
|
||||
(option '(#\x "xml") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'xml-file arg result)))))
|
||||
|
||||
(define (gnupdate . args)
|
||||
;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs.
|
||||
(let* ((opts (args-fold (cdr args) %options
|
||||
(lambda (opt name arg result)
|
||||
(error "unrecognized option `~A'" name))
|
||||
(lambda (operand result)
|
||||
(error "extraneous argument `~A'" operand))
|
||||
'()))
|
||||
(home (getenv "HOME"))
|
||||
(path (or (getenv "NIXPKGS")
|
||||
(string-append home "/src/nixpkgs")))
|
||||
(snix (begin
|
||||
(format (current-error-port) "parsing XML...~%")
|
||||
(xml->snix
|
||||
(or (and=> (assoc-ref opts 'xml-file) open-input-file)
|
||||
(open-nixpkgs path)))))
|
||||
(packages (match snix
|
||||
(('snix _ ('attribute-set attributes))
|
||||
attributes)
|
||||
(_ #f)))
|
||||
(stdenv (delay
|
||||
;; The source tarballs that make up stdenv.
|
||||
(filter-map derivation-source-output-path
|
||||
(package-requisites (stdenv-package packages)))))
|
||||
(gnu (gnu-packages packages))
|
||||
(gnu* (case (assoc-ref opts 'filter)
|
||||
;; Filter out packages that are/aren't in `stdenv'. To
|
||||
;; do that reliably, we check whether their "src"
|
||||
;; derivation is a requisite of stdenv.
|
||||
((stdenv)
|
||||
(filter (lambda (p)
|
||||
(member (package-source-output-path p)
|
||||
(force stdenv)))
|
||||
gnu))
|
||||
((non-stdenv)
|
||||
(filter (lambda (p)
|
||||
(not (member (package-source-output-path p)
|
||||
(force stdenv))))
|
||||
gnu))
|
||||
(else gnu)))
|
||||
(updates (packages-to-update gnu*)))
|
||||
|
||||
(format #t "~%~A packages to update...~%" (length updates))
|
||||
(for-each (lambda (update)
|
||||
(match update
|
||||
((name attribute
|
||||
old-version old-hash
|
||||
new-version new-hash
|
||||
location)
|
||||
(if (assoc-ref opts 'dry-run)
|
||||
(format #t "`~a' would be updated from ~a to ~a (~a -> ~a)~%"
|
||||
name old-version new-version
|
||||
old-hash new-hash)
|
||||
(update-nix-expression (location-file location)
|
||||
old-version old-hash
|
||||
new-version new-hash)))
|
||||
(_ #f)))
|
||||
updates)
|
||||
#t))
|
||||
|
||||
@ -1,828 +0,0 @@
|
||||
;;; GNUpdate -- Update GNU packages in Nixpkgs. -*- coding: utf-8; -*-
|
||||
;;; Copyright (C) 2010 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation, either version 3 of the License, or
|
||||
;;; (at your option) any later version.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(cond-expand (guile-2 #t)
|
||||
(else (error "GNU Guile 2.0 is required")))
|
||||
|
||||
(use-modules (sxml ssax)
|
||||
(ice-9 popen)
|
||||
(ice-9 match)
|
||||
(ice-9 rdelim)
|
||||
(ice-9 regex)
|
||||
(ice-9 vlist)
|
||||
(srfi srfi-1)
|
||||
(srfi srfi-9)
|
||||
(srfi srfi-11)
|
||||
(srfi srfi-26)
|
||||
(srfi srfi-37)
|
||||
(system foreign)
|
||||
(rnrs bytevectors))
|
||||
|
||||
|
||||
;;;
|
||||
;;; SNix.
|
||||
;;;
|
||||
|
||||
(define-record-type <location>
|
||||
(make-location file line column)
|
||||
location?
|
||||
(file location-file)
|
||||
(line location-line)
|
||||
(column location-column))
|
||||
|
||||
(define (->loc line column path)
|
||||
(and line column path
|
||||
(make-location path (string->number line) (string->number column))))
|
||||
|
||||
;; XXX: Hack to add missing exports from `(sxml ssax)' as of 1.9.10.
|
||||
(let ((ssax (resolve-module '(sxml ssax))))
|
||||
(for-each (lambda (sym)
|
||||
(module-add! (current-module) sym
|
||||
(module-variable ssax sym)))
|
||||
'(ssax:warn ssax:skip-pi nl)))
|
||||
|
||||
;; Nix object types visible in the XML output of `nix-instantiate' and
|
||||
;; mapping to S-expressions (we map to sexps, not records, so that we
|
||||
;; can do pattern matching):
|
||||
;;
|
||||
;; at (at varpat attrspat)
|
||||
;; attr (attribute loc name value)
|
||||
;; attrs (attribute-set attributes)
|
||||
;; attrspat (attribute-set-pattern patterns)
|
||||
;; bool #f|#t
|
||||
;; derivation (derivation drv-path out-path attributes)
|
||||
;; ellipsis '...
|
||||
;; expr (snix loc body ...)
|
||||
;; function (function loc at|attrspat|varpat)
|
||||
;; int int
|
||||
;; list list
|
||||
;; null 'null
|
||||
;; path string
|
||||
;; string string
|
||||
;; unevaluated 'unevaluated
|
||||
;; varpat (varpat name)
|
||||
;;
|
||||
;; Initially ATTRIBUTES in `derivation' and `attribute-set' was a promise;
|
||||
;; however, handling `repeated' nodes makes it impossible to do anything
|
||||
;; lazily because the whole SXML tree has to be traversed to maintain the
|
||||
;; list of known derivations.
|
||||
|
||||
(define (xml-element->snix elem attributes body derivations)
|
||||
;; Return an SNix element corresponding to XML element ELEM.
|
||||
|
||||
(define (loc)
|
||||
(->loc (assq-ref attributes 'line)
|
||||
(assq-ref attributes 'column)
|
||||
(assq-ref attributes 'path)))
|
||||
|
||||
(case elem
|
||||
((at)
|
||||
(values `(at ,(car body) ,(cadr body)) derivations))
|
||||
((attr)
|
||||
(let ((name (assq-ref attributes 'name)))
|
||||
(cond ((null? body)
|
||||
(values `(attribute-pattern ,name) derivations))
|
||||
((and (pair? body) (null? (cdr body)))
|
||||
(values `(attribute ,(loc) ,name ,(car body))
|
||||
derivations))
|
||||
(else
|
||||
(error "invalid attribute body" name (loc) body)))))
|
||||
((attrs)
|
||||
(values `(attribute-set ,(reverse body)) derivations))
|
||||
((attrspat)
|
||||
(values `(attribute-set-pattern ,body) derivations))
|
||||
((bool)
|
||||
(values (string-ci=? "true" (assq-ref attributes 'value))
|
||||
derivations))
|
||||
((derivation)
|
||||
(let ((drv-path (assq-ref attributes 'drvPath))
|
||||
(out-path (assq-ref attributes 'outPath)))
|
||||
(if (equal? body '(repeated))
|
||||
(let ((body (vhash-assoc drv-path derivations)))
|
||||
(if (pair? body)
|
||||
(values `(derivation ,drv-path ,out-path ,(cdr body))
|
||||
derivations)
|
||||
(error "no previous occurrence of derivation"
|
||||
drv-path)))
|
||||
(values `(derivation ,drv-path ,out-path ,body)
|
||||
(vhash-cons drv-path body derivations)))))
|
||||
((ellipsis)
|
||||
(values '... derivations))
|
||||
((expr)
|
||||
(values `(snix ,(loc) ,@body) derivations))
|
||||
((function)
|
||||
(values `(function ,(loc) ,body) derivations))
|
||||
((int)
|
||||
(values (string->number (assq-ref attributes 'value))
|
||||
derivations))
|
||||
((list)
|
||||
(values body derivations))
|
||||
((null)
|
||||
(values 'null derivations))
|
||||
((path)
|
||||
(values (assq-ref attributes 'value) derivations))
|
||||
((repeated)
|
||||
(values 'repeated derivations))
|
||||
((string)
|
||||
(values (assq-ref attributes 'value) derivations))
|
||||
((unevaluated)
|
||||
(values 'unevaluated derivations))
|
||||
((varpat)
|
||||
(values `(varpat ,(assq-ref attributes 'name)) derivations))
|
||||
(else (error "unhandled Nix XML element" elem))))
|
||||
|
||||
(define xml->snix
|
||||
;; Return the SNix represention of TREE, an SXML tree as returned by
|
||||
;; parsing the XML output of `nix-instantiate' on Nixpkgs.
|
||||
(let ((parse
|
||||
(ssax:make-parser NEW-LEVEL-SEED
|
||||
(lambda (elem-gi attributes namespaces expected-content
|
||||
seed)
|
||||
(cons '() (cdr seed)))
|
||||
|
||||
FINISH-ELEMENT
|
||||
(lambda (elem-gi attributes namespaces parent-seed
|
||||
seed)
|
||||
(let ((snix (car seed))
|
||||
(derivations (cdr seed)))
|
||||
(let-values (((snix derivations)
|
||||
(xml-element->snix elem-gi
|
||||
attributes
|
||||
snix
|
||||
derivations)))
|
||||
(cons (cons snix (car parent-seed))
|
||||
derivations))))
|
||||
|
||||
CHAR-DATA-HANDLER
|
||||
(lambda (string1 string2 seed)
|
||||
;; Discard inter-node strings, which are blanks.
|
||||
seed))))
|
||||
(lambda (port)
|
||||
;; Discard the second value returned by the parser (the derivation
|
||||
;; vhash).
|
||||
(caar (parse port (cons '() vlist-null))))))
|
||||
|
||||
(define (call-with-package snix proc)
|
||||
(match snix
|
||||
(('attribute _ (and attribute-name (? string?))
|
||||
('derivation _ _ body))
|
||||
;; Ugly pattern matching.
|
||||
(let ((meta
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "meta" ('attribute-set metas)) metas)
|
||||
(_ #f)))
|
||||
body))
|
||||
(package-name
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "name" (and name (? string?)))
|
||||
name)
|
||||
(_ #f)))
|
||||
body))
|
||||
(location
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute loc "name" (? string?))
|
||||
loc)
|
||||
(_ #f)))
|
||||
body))
|
||||
(src
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "src" src)
|
||||
src)
|
||||
(_ #f)))
|
||||
body)))
|
||||
(proc attribute-name package-name location meta src)))))
|
||||
|
||||
(define (call-with-src snix proc)
|
||||
;; Assume SNIX contains the SNix expression for the value of an `src'
|
||||
;; attribute, as returned by `call-with-package', and call PROC with the
|
||||
;; relevant SRC information, or #f if SNIX doesn't match.
|
||||
(match snix
|
||||
(('derivation _ _ body)
|
||||
(let ((name
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "name" (and name (? string?)))
|
||||
name)
|
||||
(_ #f)))
|
||||
body))
|
||||
(output-hash
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "outputHash" (and hash (? string?)))
|
||||
hash)
|
||||
(_ #f)))
|
||||
body))
|
||||
(urls
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "urls" (and urls (? pair?)))
|
||||
urls)
|
||||
(_ #f)))
|
||||
body)))
|
||||
(proc name output-hash urls)))
|
||||
(_ (proc #f #f #f))))
|
||||
|
||||
(define (src->values snix)
|
||||
(call-with-src snix values))
|
||||
|
||||
(define (attribute-value attribute)
|
||||
;; Return the value of ATTRIBUTE.
|
||||
(match attribute
|
||||
(('attribute _ _ value) value)))
|
||||
|
||||
(define (derivation-source derivation)
|
||||
;; Return the "src" attribute of DERIVATION or #f if not found.
|
||||
(match derivation
|
||||
(('derivation _ _ (attributes ...))
|
||||
(find-attribute-by-name "src" attributes))))
|
||||
|
||||
(define (derivation-output-path derivation)
|
||||
;; Return the output path of DERIVATION.
|
||||
(match derivation
|
||||
(('derivation _ out-path _)
|
||||
out-path)
|
||||
(_ #f)))
|
||||
|
||||
(define (source-output-path src)
|
||||
;; Return the output path of SRC, the "src" attribute of a derivation.
|
||||
(derivation-output-path (attribute-value src)))
|
||||
|
||||
(define (derivation-source-output-path derivation)
|
||||
;; Return the output path of the "src" attribute of DERIVATION or #f if
|
||||
;; DERIVATION lacks an "src" attribute.
|
||||
(and=> (derivation-source derivation) source-output-path))
|
||||
|
||||
(define (open-nixpkgs nixpkgs)
|
||||
(let ((script (string-append nixpkgs
|
||||
"/maintainers/scripts/eval-release.nix")))
|
||||
(open-pipe* OPEN_READ "nix-instantiate"
|
||||
"--strict" "--eval-only" "--xml"
|
||||
script)))
|
||||
|
||||
(define (nix-prefetch-url url)
|
||||
;; Download URL in the Nix store and return the base32-encoded SHA256 hash
|
||||
;; of the file at URL
|
||||
(let* ((pipe (open-pipe* OPEN_READ "nix-prefetch-url" url))
|
||||
(hash (read-line pipe)))
|
||||
(close-pipe pipe)
|
||||
(if (eof-object? hash)
|
||||
(values #f #f)
|
||||
(let* ((pipe (open-pipe* OPEN_READ "nix-store" "--print-fixed-path"
|
||||
"sha256" hash (basename url)))
|
||||
(path (read-line pipe)))
|
||||
(if (eof-object? path)
|
||||
(values #f #f)
|
||||
(values (string-trim-both hash) (string-trim-both path)))))))
|
||||
|
||||
(define (update-nix-expression file
|
||||
old-version old-hash
|
||||
new-version new-hash)
|
||||
;; Modify FILE in-place. Ugly: we call out to sed(1).
|
||||
(let ((cmd (format #f "sed -i \"~a\" -e 's/~A/~a/g ; s/~A/~A/g'"
|
||||
file
|
||||
(regexp-quote old-version) new-version
|
||||
old-hash
|
||||
(or new-hash "new hash not available, check the log"))))
|
||||
(format #t "running `~A'...~%" cmd)
|
||||
(system cmd)))
|
||||
|
||||
(define (find-attribute-by-name name attributes)
|
||||
;; Return attribute NAME in ATTRIBUTES, a list of SNix attributes, or #f if
|
||||
;; NAME cannot be found.
|
||||
(find (lambda (a)
|
||||
(match a
|
||||
(('attribute _ (? (cut string=? <> name)) _)
|
||||
a)
|
||||
(_ #f)))
|
||||
attributes))
|
||||
|
||||
(define (find-package-by-attribute-name name packages)
|
||||
;; Return the package bound to attribute NAME in PACKAGES, a list of
|
||||
;; packages (SNix attributes), or #f if NAME cannot be found.
|
||||
(find (lambda (package)
|
||||
(match package
|
||||
(('attribute _ (? (cut string=? <> name))
|
||||
('derivation _ _ _))
|
||||
package)
|
||||
(_ #f)))
|
||||
packages))
|
||||
|
||||
(define (stdenv-package packages)
|
||||
;; Return the `stdenv' package from PACKAGES, a list of SNix attributes.
|
||||
(find-package-by-attribute-name "stdenv" packages))
|
||||
|
||||
(define (package-requisites package)
|
||||
;; Return the list of derivations required to build PACKAGE (including that
|
||||
;; of PACKAGE) by recurring into its derivation attributes.
|
||||
(let loop ((snix package)
|
||||
(result '()))
|
||||
(match snix
|
||||
(('attribute _ _ body)
|
||||
(loop body result))
|
||||
(('derivation _ out-path body)
|
||||
(if (any (lambda (d)
|
||||
(match d
|
||||
(('derivation _ (? (cut string=? out-path <>)) _) #t)
|
||||
(_ #f)))
|
||||
result)
|
||||
result
|
||||
(loop body (cons snix result))))
|
||||
((things ...)
|
||||
(fold loop result things))
|
||||
(_ result))))
|
||||
|
||||
(define (package-source-output-path package)
|
||||
;; Return the output path of the "src" derivation of PACKAGE.
|
||||
(derivation-source-output-path (attribute-value package)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; FTP client.
|
||||
;;;
|
||||
|
||||
(define-record-type <ftp-connection>
|
||||
(%make-ftp-connection socket addrinfo)
|
||||
ftp-connection?
|
||||
(socket ftp-connection-socket)
|
||||
(addrinfo ftp-connection-addrinfo))
|
||||
|
||||
(define %ftp-ready-rx
|
||||
(make-regexp "^([0-9]{3}) (.+)$"))
|
||||
|
||||
(define (%ftp-listen port)
|
||||
(let loop ((line (read-line port)))
|
||||
(cond ((eof-object? line) (values line #f))
|
||||
((regexp-exec %ftp-ready-rx line)
|
||||
=>
|
||||
(lambda (match)
|
||||
(values (string->number (match:substring match 1))
|
||||
(match:substring match 2))))
|
||||
(else
|
||||
(loop (read-line port))))))
|
||||
|
||||
(define (%ftp-command command expected-code port)
|
||||
(format port "~A~A~A" command (string #\return) (string #\newline))
|
||||
(let-values (((code message) (%ftp-listen port)))
|
||||
(if (eqv? code expected-code)
|
||||
message
|
||||
(throw 'ftp-error port command code message))))
|
||||
|
||||
(define (%ftp-login user pass port)
|
||||
(let ((command (string-append "USER " user (string #\newline))))
|
||||
(display command port)
|
||||
(let-values (((code message) (%ftp-listen port)))
|
||||
(case code
|
||||
((230) #t)
|
||||
((331) (%ftp-command (string-append "PASS " pass) 230 port))
|
||||
(else (throw 'ftp-error port command code message))))))
|
||||
|
||||
(define (ftp-open host)
|
||||
(catch 'getaddrinfo-error
|
||||
(lambda ()
|
||||
(let* ((ai (car (getaddrinfo host "ftp")))
|
||||
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
|
||||
(addrinfo:protocol ai))))
|
||||
(connect s (addrinfo:addr ai))
|
||||
(setvbuf s _IOLBF)
|
||||
(let-values (((code message) (%ftp-listen s)))
|
||||
(if (eqv? code 220)
|
||||
(begin
|
||||
;(%ftp-command "OPTS UTF8 ON" 200 s)
|
||||
(%ftp-login "anonymous" "ludo@example.com" s)
|
||||
(%make-ftp-connection s ai))
|
||||
(begin
|
||||
(format (current-error-port) "FTP to `~a' failed: ~A: ~A~%"
|
||||
host code message)
|
||||
(close s)
|
||||
#f)))))
|
||||
(lambda (key errcode)
|
||||
(format (current-error-port) "failed to resolve `~a': ~a~%"
|
||||
host (gai-strerror errcode))
|
||||
#f)))
|
||||
|
||||
(define (ftp-close conn)
|
||||
(close (ftp-connection-socket conn)))
|
||||
|
||||
(define (ftp-chdir conn dir)
|
||||
(%ftp-command (string-append "CWD " dir) 250
|
||||
(ftp-connection-socket conn)))
|
||||
|
||||
(define (ftp-pasv conn)
|
||||
(define %pasv-rx
|
||||
(make-regexp "([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)"))
|
||||
|
||||
(let ((message (%ftp-command "PASV" 227 (ftp-connection-socket conn))))
|
||||
(cond ((regexp-exec %pasv-rx message)
|
||||
=>
|
||||
(lambda (match)
|
||||
(+ (* (string->number (match:substring match 5)) 256)
|
||||
(string->number (match:substring match 6)))))
|
||||
(else
|
||||
(throw 'ftp-error conn "PASV" 227 message)))))
|
||||
|
||||
|
||||
(define* (ftp-list conn #:optional directory)
|
||||
(define (address-with-port sa port)
|
||||
(let ((fam (sockaddr:fam sa))
|
||||
(addr (sockaddr:addr sa)))
|
||||
(cond ((= fam AF_INET)
|
||||
(make-socket-address fam addr port))
|
||||
((= fam AF_INET6)
|
||||
(make-socket-address fam addr port
|
||||
(sockaddr:flowinfo sa)
|
||||
(sockaddr:scopeid sa)))
|
||||
(else #f))))
|
||||
|
||||
(if directory
|
||||
(ftp-chdir conn directory))
|
||||
|
||||
(let* ((port (ftp-pasv conn))
|
||||
(ai (ftp-connection-addrinfo conn))
|
||||
(s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
|
||||
(addrinfo:protocol ai))))
|
||||
(connect s (address-with-port (addrinfo:addr ai) port))
|
||||
(setvbuf s _IOLBF)
|
||||
|
||||
(dynamic-wind
|
||||
(lambda () #t)
|
||||
(lambda ()
|
||||
(%ftp-command "LIST" 150 (ftp-connection-socket conn))
|
||||
|
||||
(let loop ((line (read-line s))
|
||||
(result '()))
|
||||
(cond ((eof-object? line) (reverse result))
|
||||
((regexp-exec %ftp-ready-rx line)
|
||||
=>
|
||||
(lambda (match)
|
||||
(let ((code (string->number (match:substring match 1))))
|
||||
(if (= 126 code)
|
||||
(reverse result)
|
||||
(throw 'ftp-error conn "LIST" code)))))
|
||||
(else
|
||||
(loop (read-line s)
|
||||
(let ((file (car (reverse (string-tokenize line)))))
|
||||
(cons file result)))))))
|
||||
(lambda ()
|
||||
(close s)
|
||||
(let-values (((code message) (%ftp-listen (ftp-connection-socket conn))))
|
||||
(or (eqv? code 226)
|
||||
(throw 'ftp-error conn "LIST" code message)))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; GNU.
|
||||
;;;
|
||||
|
||||
(define %ignored-package-attributes
|
||||
;; Attribute name of packages to be ignored.
|
||||
'("bash" "bashReal" "bashInteractive" ;; the full versioned name is incorrect
|
||||
"autoconf213"
|
||||
"automake17x"
|
||||
"automake19x"
|
||||
"automake110x"
|
||||
"automake" ;; = 1.10.x
|
||||
"bison1875"
|
||||
"bison23"
|
||||
"bison" ;; = 2.3
|
||||
"emacs22"
|
||||
"emacsSnapshot"
|
||||
"gcc295"
|
||||
"gcc33"
|
||||
"gcc34"
|
||||
"gcc40"
|
||||
"gcc41"
|
||||
"gcc42"
|
||||
"gcc43"
|
||||
"gcc44"
|
||||
"gcc45"
|
||||
"glibc25"
|
||||
"glibc27"
|
||||
"glibc29"
|
||||
"guile_1_9"
|
||||
))
|
||||
|
||||
(define (gnu? package)
|
||||
;; Return true if PACKAGE (a snix expression) is a GNU package (according
|
||||
;; to a simple heuristic.) Otherwise return #f.
|
||||
(match package
|
||||
(('attribute _ _ ('derivation _ _ body))
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "meta" ('attribute-set metas))
|
||||
(any (lambda (attr)
|
||||
(match attr
|
||||
(('attribute _ "description" value)
|
||||
(string-prefix? "GNU" value))
|
||||
(('attribute _ "homepage" value)
|
||||
(string-contains value "www.gnu.org"))
|
||||
(_ #f)))
|
||||
metas))
|
||||
(_ #f)))
|
||||
body))
|
||||
(_ #f)))
|
||||
|
||||
(define (gnu-packages packages)
|
||||
(fold (lambda (package gnu)
|
||||
(match package
|
||||
(('attribute _ "emacs23Packages" emacs-packages)
|
||||
;; XXX: Should prepend `emacs23Packages.' to attribute names.
|
||||
(append (gnu-packages emacs-packages) gnu))
|
||||
(('attribute _ attribute-name ('derivation _ _ body))
|
||||
(if (member attribute-name %ignored-package-attributes)
|
||||
gnu
|
||||
(if (gnu? package)
|
||||
(cons package gnu)
|
||||
gnu)))
|
||||
(_ gnu)))
|
||||
'()
|
||||
packages))
|
||||
|
||||
(define (ftp-server/directory project)
|
||||
(define quirks
|
||||
'(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp" #f)
|
||||
("libgcrypt" "ftp.gnupg.org" "/gcrypt" #t)
|
||||
("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t)
|
||||
("gnupg" "ftp.gnupg.org" "/gcrypt" #t)
|
||||
("gnu-ghostscript" "ftp.gnu.org" "/ghostscript" #f)
|
||||
("grub" "alpha.gnu.org" "/gnu" #t)
|
||||
("GNUnet" "ftp.gnu.org" "/gnu/gnunet" #f)
|
||||
("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg")
|
||||
("icecat" "ftp.gnu.org" "/gnu/gnuzilla" #f)
|
||||
("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz" #f)))
|
||||
|
||||
(let ((quirk (assoc project quirks)))
|
||||
(match quirk
|
||||
((_ server directory subdir?)
|
||||
(values server (if (not subdir?)
|
||||
directory
|
||||
(string-append directory "/" project))))
|
||||
(_
|
||||
(values "ftp.gnu.org" (string-append "/gnu/" project))))))
|
||||
|
||||
(define (nixpkgs->gnu-name project)
|
||||
(define quirks
|
||||
'(("gcc-wrapper" . "gcc")
|
||||
("ghostscript" . "gnu-ghostscript") ;; ../ghostscript/gnu-ghoscript-X.Y.tar.gz
|
||||
("gnum4" . "m4")
|
||||
("gnugrep" . "grep")
|
||||
("gnused" . "sed")
|
||||
("gnutar" . "tar")
|
||||
("gnunet" . "GNUnet") ;; ftp.gnu.org/gnu/gnunet/GNUnet-x.y.tar.gz
|
||||
("mitscheme" . "mit-scheme")
|
||||
("texmacs" . "TeXmacs")))
|
||||
|
||||
(or (assoc-ref quirks project) project))
|
||||
|
||||
(define (releases project)
|
||||
;; TODO: Handle project release trees like that of IceCat and MyServer.
|
||||
(define release-rx
|
||||
(make-regexp (string-append "^" project "-[0-9].*\\.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)
|
||||
(let ((end (string-contains tarball ".tar")))
|
||||
(substring tarball 0 end)))
|
||||
|
||||
;; 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)
|
||||
(and (not (string-suffix? ".sig" file))
|
||||
(regexp-exec release-rx file)))
|
||||
files)))))
|
||||
(lambda (key subr message . args)
|
||||
(format (current-error-port)
|
||||
"failed to get release list for `~A': ~A ~A~%"
|
||||
project message args)
|
||||
'())))
|
||||
|
||||
(define version-string>?
|
||||
(let ((strverscmp
|
||||
(let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
|
||||
(error "could not find `strverscmp' (from GNU libc)"))))
|
||||
(make-foreign-function int sym (list '* '*))))
|
||||
(string->null-terminated-utf8
|
||||
(lambda (s)
|
||||
(let* ((utf8 (string->utf8 s))
|
||||
(len (bytevector-length utf8))
|
||||
(nts (make-bytevector (+ len 1))))
|
||||
(bytevector-copy! utf8 0 nts 0 len)
|
||||
(bytevector-u8-set! nts len 0)
|
||||
nts))))
|
||||
(lambda (a b)
|
||||
(let ((a (bytevector->foreign (string->null-terminated-utf8 a)))
|
||||
(b (bytevector->foreign (string->null-terminated-utf8 b))))
|
||||
(> (strverscmp a b) 0)))))
|
||||
|
||||
(define (latest-release project)
|
||||
;; Return "FOO-X.Y" or #f.
|
||||
(let ((releases (releases project)))
|
||||
(and (not (null? releases))
|
||||
(fold (lambda (release latest)
|
||||
(if (version-string>? release latest)
|
||||
release
|
||||
latest))
|
||||
""
|
||||
releases))))
|
||||
|
||||
(define (package/version name+version)
|
||||
(let ((hyphen (string-rindex name+version #\-)))
|
||||
(if (not hyphen)
|
||||
(values name+version #f)
|
||||
(let ((name (substring name+version 0 hyphen))
|
||||
(version (substring name+version (+ hyphen 1)
|
||||
(string-length name+version))))
|
||||
(values name version)))))
|
||||
|
||||
(define (file-extension file)
|
||||
(let ((dot (string-rindex file #\.)))
|
||||
(and dot (substring file (+ 1 dot) (string-length file)))))
|
||||
|
||||
(define (packages-to-update gnu-packages)
|
||||
(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)
|
||||
(format #t "~A [unknown latest version]~%"
|
||||
name+version)
|
||||
result)
|
||||
((string=? name+version latest)
|
||||
(format #t "~A [up to date]~%" name+version)
|
||||
result)
|
||||
(else
|
||||
(let-values (((project new-version)
|
||||
(package/version latest))
|
||||
((old-name old-hash old-urls)
|
||||
(src->values src)))
|
||||
(format #t "~A -> ~A [~A]~%" name+version latest
|
||||
(and (pair? old-urls) (car old-urls)))
|
||||
(let* ((url (and (pair? old-urls)
|
||||
(car old-urls)))
|
||||
(new-hash (fetch-gnu project new-version
|
||||
(if url
|
||||
(file-extension url)
|
||||
"gz"))))
|
||||
(cons (list name attribute
|
||||
old-version old-hash
|
||||
new-version new-hash
|
||||
location)
|
||||
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))
|
||||
(url (string-append "ftp://" server "/" directory "/" base))
|
||||
(sig (string-append base ".sig"))
|
||||
(sig-url (string-append url ".sig")))
|
||||
(let-values (((hash path) (nix-prefetch-url url)))
|
||||
(pk 'prefetch-url url hash path)
|
||||
(and hash path
|
||||
(begin
|
||||
(false-if-exception (delete-file sig))
|
||||
(system* "wget" sig-url)
|
||||
(if (file-exists? sig)
|
||||
(let ((ret (system* "gpg" "--verify" sig path)))
|
||||
(false-if-exception (delete-file sig))
|
||||
(if (and ret (= 0 (status:exit-val ret)))
|
||||
hash
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"signature verification failed for `~a'~%"
|
||||
base)
|
||||
(format (current-error-port)
|
||||
"(could be because the public key is not in your keyring)~%")
|
||||
#f)))
|
||||
(begin
|
||||
(format (current-error-port)
|
||||
"no signature for `~a'~%" base)
|
||||
hash))))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Main program.
|
||||
;;;
|
||||
|
||||
(define %options
|
||||
;; Specifications of the command-line options.
|
||||
(list (option '(#\h "help") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(format #t "Usage: gnupdate [OPTIONS...]~%")
|
||||
(format #t "GNUpdate -- update Nix expressions of GNU packages in Nixpkgs~%")
|
||||
(format #t "~%")
|
||||
(format #t " -x, --xml=FILE Read XML output of `nix-instantiate'~%")
|
||||
(format #t " from FILE.~%")
|
||||
(format #t " -s, --select=SET Update only packages from SET, which may~%")
|
||||
(format #t " be either `all',`stdenv', or `non-stdenv'.~%")
|
||||
(format #t " -d, --dry-run Don't actually update Nix expressions~%")
|
||||
(format #t " -h, --help Give this help list.~%~%")
|
||||
(format #t "Report bugs to <ludo@gnu.org>~%")
|
||||
(exit 0)))
|
||||
(option '(#\s "select") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(cond ((string-ci=? arg "stdenv")
|
||||
(alist-cons 'filter 'stdenv result))
|
||||
((string-ci=? arg "non-stdenv")
|
||||
(alist-cons 'filter 'non-stdenv result))
|
||||
((string-ci=? arg "all")
|
||||
(alist-cons 'filter #f result))
|
||||
(else
|
||||
(format (current-error-port)
|
||||
"~A: unrecognized selection type~%"
|
||||
arg)
|
||||
(exit 1)))))
|
||||
|
||||
(option '(#\d "dry-run") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'dry-run #t result)))
|
||||
|
||||
(option '(#\x "xml") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'xml-file arg result)))))
|
||||
|
||||
(define-public (main . args)
|
||||
;; Assume Nixpkgs is under $NIXPKGS or ~/src/nixpkgs.
|
||||
(let* ((opts (args-fold args %options
|
||||
(lambda (opt name arg result)
|
||||
(error "unrecognized option `~A'" name))
|
||||
(lambda (operand result)
|
||||
(error "extraneous argument `~A'" operand))
|
||||
'()))
|
||||
(home (getenv "HOME"))
|
||||
(path (or (getenv "NIXPKGS")
|
||||
(string-append home "/src/nixpkgs")))
|
||||
(snix (begin
|
||||
(format (current-error-port) "parsing XML...~%")
|
||||
(xml->snix
|
||||
(or (and=> (assoc-ref opts 'xml-file) open-input-file)
|
||||
(open-nixpkgs path)))))
|
||||
(packages (match snix
|
||||
(('snix _ ('attribute-set attributes))
|
||||
attributes)
|
||||
(_ #f)))
|
||||
(stdenv (delay
|
||||
;; The source tarballs that make up stdenv.
|
||||
(filter-map derivation-source-output-path
|
||||
(package-requisites (stdenv-package packages)))))
|
||||
(gnu (gnu-packages packages))
|
||||
(gnu* (case (assoc-ref opts 'filter)
|
||||
;; Filter out packages that are/aren't in `stdenv'. To
|
||||
;; do that reliably, we check whether their "src"
|
||||
;; derivation is a requisite of stdenv.
|
||||
((stdenv)
|
||||
(filter (lambda (p)
|
||||
(member (package-source-output-path p)
|
||||
(force stdenv)))
|
||||
gnu))
|
||||
((non-stdenv)
|
||||
(filter (lambda (p)
|
||||
(not (member (package-source-output-path p)
|
||||
(force stdenv))))
|
||||
gnu))
|
||||
(else gnu)))
|
||||
(updates (packages-to-update gnu*)))
|
||||
|
||||
(format #t "~%~A packages to update...~%" (length updates))
|
||||
(for-each (lambda (update)
|
||||
(match update
|
||||
((name attribute
|
||||
old-version old-hash
|
||||
new-version new-hash
|
||||
location)
|
||||
(if (assoc-ref opts 'dry-run)
|
||||
(format #t "`~a' would be updated from ~a to ~a (~a -> ~a)~%"
|
||||
name old-version new-version
|
||||
old-hash new-hash)
|
||||
(update-nix-expression (location-file location)
|
||||
old-version old-hash
|
||||
new-version new-hash)))
|
||||
(_ #f)))
|
||||
updates)
|
||||
#t))
|
||||
Loading…
Reference in New Issue
Block a user