diff --git a/maintainers/scripts/gnu/gnupdate b/maintainers/scripts/gnu/gnupdate deleted file mode 100755 index 6bb379f4fd2e..000000000000 --- a/maintainers/scripts/gnu/gnupdate +++ /dev/null @@ -1,1122 +0,0 @@ -#!/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, 2011 Ludovic Courtès -;;; -;;; 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 . - -(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 format) - #: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 - (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)))) - -;; 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) - - ;; DRV-PATH hasn't been encountered yet but may be later - ;; (see .) - ;; Return an `unresolved' node. - (values `(unresolved - ,(lambda (derivations) - (let ((body (vhash-assoc drv-path derivations))) - (if (pair? body) - `(derivation ,drv-path ,out-path - ,(cdr body)) - (error "no previous occurrence of derivation" - drv-path))))) - derivations))) - (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 (resolve snix derivations) - "Return a new SNix tree where `unresolved' nodes from SNIX have been -replaced by the result of their application to DERIVATIONS, a vhash." - (let loop ((node snix) - (seen vlist-null)) - (if (vhash-assq node seen) - (values node seen) - (match node - (('unresolved proc) - (let ((n (proc derivations))) - (values n seen))) - ((tag body ...) - (let ((body+seen (fold (lambda (n body+seen) - (call-with-values - (lambda () - (loop n (cdr body+seen))) - (lambda (n* seen) - (cons (cons n* (car body+seen)) - (vhash-consq n #t seen))))) - (cons '() (vhash-consq node #t seen)) - body))) - (values (cons tag (reverse (car body+seen))) - (vhash-consq node #t (cdr body+seen))))) - (anything - (values anything seen)))))) - -(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) - (match (parse port (cons '() vlist-null)) - (((snix) . derivations) - (resolve snix derivations)))))) - -(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 #:optional attribute) - ;; Return an input pipe to the XML representation of Nixpkgs. When - ;; ATTRIBUTE is true, only that attribute is considered. - (let ((script (string-append nixpkgs - "/maintainers/scripts/eval-release.nix"))) - (apply open-pipe* OPEN_READ - "nix-instantiate" "--strict" "--eval-only" "--xml" - `(,@(if attribute - `("-A" ,attribute) - '()) - ,script)))) - -(define (pipe-failed? pipe) - "Close pipe and return its status if it failed." - (let ((status (close-pipe pipe))) - (if (or (status:term-sig status) - (not (= (status:exit-val status) 0))) - status - #f))) - -(define (memoize proc) - "Return a memoizing version of PROC." - (let ((cache (make-hash-table))) - (lambda args - (let ((results (hash-ref cache args))) - (if results - (apply values results) - (let ((results (call-with-values (lambda () - (apply proc args)) - list))) - (hash-set! cache args results) - (apply values results))))))) - -(define nix-prefetch-url - (memoize - (lambda (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))) - (if (or (pipe-failed? pipe) - (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 (or (pipe-failed? pipe) - (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))) - - -;;; -;;; GnuPG interface. -;;; - -(define %gpg-command "gpg2") -(define %openpgp-key-server "keys.gnupg.net") - -(define (gnupg-verify sig file) - "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed." - - (define (status-line->sexp line) - ;; See file `doc/DETAILS' in GnuPG. - (define sigid-rx - (make-regexp - "^\\[GNUPG:\\] SIG_ID ([A-Za-z0-9/]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+)")) - (define goodsig-rx - (make-regexp "^\\[GNUPG:\\] GOODSIG ([[:xdigit:]]+) (.+)$")) - (define validsig-rx - (make-regexp - "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) - (define expkeysig-rx ; good signature, but expired key - (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) - (define errsig-rx - (make-regexp - "^\\[GNUPG:\\] ERRSIG ([[:xdigit:]]+) ([^ ]+) ([^ ]+) ([^ ]+) ([[:digit:]]+) ([[:digit:]]+)")) - - (cond ((regexp-exec sigid-rx line) - => - (lambda (match) - `(signature-id ,(match:substring match 1) ; sig id - ,(match:substring match 2) ; date - ,(string->number ; timestamp - (match:substring match 3))))) - ((regexp-exec goodsig-rx line) - => - (lambda (match) - `(good-signature ,(match:substring match 1) ; key id - ,(match:substring match 2)))) ; user name - ((regexp-exec validsig-rx line) - => - (lambda (match) - `(valid-signature ,(match:substring match 1) ; fingerprint - ,(match:substring match 2) ; sig creation date - ,(string->number ; timestamp - (match:substring match 3))))) - ((regexp-exec expkeysig-rx line) - => - (lambda (match) - `(expired-key-signature ,(match:substring match 1) ; fingerprint - ,(match:substring match 2)))) ; user name - ((regexp-exec errsig-rx line) - => - (lambda (match) - `(signature-error ,(match:substring match 1) ; key id or fingerprint - ,(match:substring match 2) ; pubkey algo - ,(match:substring match 3) ; hash algo - ,(match:substring match 4) ; sig class - ,(string->number ; timestamp - (match:substring match 5)) - ,(let ((rc - (string->number ; return code - (match:substring match 6)))) - (case rc - ((9) 'missing-key) - ((4) 'unknown-algorithm) - (else rc)))))) - (else - `(unparsed-line ,line)))) - - (define (parse-status input) - (let loop ((line (read-line input)) - (result '())) - (if (eof-object? line) - (reverse result) - (loop (read-line input) - (cons (status-line->sexp line) result))))) - - (let* ((pipe (open-pipe* OPEN_READ %gpg-command "--status-fd=1" - "--verify" sig file)) - (status (parse-status pipe))) - ;; Ignore PIPE's exit status since STATUS above should contain all the - ;; info we need. - (close-pipe pipe) - status)) - -(define (gnupg-status-good-signature? status) - "If STATUS, as returned by `gnupg-verify', denotes a good signature, return -a key-id/user pair; return #f otherwise." - (any (lambda (sexp) - (match sexp - (((or 'good-signature 'expired-key-signature) key-id user) - (cons key-id user)) - (_ #f))) - status)) - -(define (gnupg-status-missing-key? status) - "If STATUS denotes a missing-key error, then return the key-id of the -missing key." - (any (lambda (sexp) - (match sexp - (('signature-error key-id _ ...) - key-id) - (_ #f))) - status)) - -(define (gnupg-receive-keys key-id) - (system* %gpg-command "--keyserver" %openpgp-key-server "--recv-keys" key-id)) - -(define (gnupg-verify* sig file) - "Like `gnupg-verify', but try downloading the public key if it's missing. -Return #t if the signature was good, #f otherwise." - (let ((status (gnupg-verify sig file))) - (or (gnupg-status-good-signature? status) - (let ((missing (gnupg-status-missing-key? status))) - (and missing - (begin - ;; Download the missing key and try again. - (gnupg-receive-keys missing) - (gnupg-status-good-signature? (gnupg-verify sig file)))))))) - - -;;; -;;; FTP client. -;;; - -(define-record-type - (%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) - (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)))) - (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" - "bison1875" - "bison23" - "bison24" - "bison" ;; = 2.4 - "ccrtp_1_8" - "emacs22" - "emacsSnapshot" - "gcc295" - "gcc33" - "gcc34" - "gcc40" - "gcc41" - "gcc42" - "gcc43" - "gcc44" - "gcc45" - "gcc45_real" - "gcc45_realCross" - "gfortran45" - "gcj45" - "gcc46" - "gcc46_real" - "gcc46_realCross" - "gfortran46" - "gcj46" - "glibc25" - "glibc27" - "glibc29" - "guile_1_8" - "icecat3" - "icecat3Xul" ;; redundant with `icecat' - "icecatWrapper" - "icecat3Wrapper" - "icecatXulrunner3" - "libzrtpcpp_1_6" - "parted_2_3" - )) - -(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" (? string? value)) - (or (string-contains value "gnu.org") - (string-contains value "gnupg.org"))) - (('attribute _ "homepage" ((? string? value) ...)) - (any (cut string-contains <> "www.gnu.org") value)) - (_ #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) - ("ucommon" "ftp.gnu.org" "/gnu/commoncpp" #f) - ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp" #f) - ("libosip2" "ftp.gnu.org" "/gnu/osip" #f) - ("libgcrypt" "ftp.gnupg.org" "/gcrypt" #t) - ("libgpg-error" "ftp.gnupg.org" "/gcrypt" #t) - ("libassuan" "ftp.gnupg.org" "/gcrypt" #t) - ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont" #f) - ("gnupg" "ftp.gnupg.org" "/gcrypt" #t) - ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript" #f) - ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg" #f) - ("icecat" "ftp.gnu.org" "/gnu/gnuzilla" #f) - ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite" #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") - ("gnumake" . "make") - ("gnused" . "sed") - ("gnutar" . "tar") - ("mitscheme" . "mit-scheme") - ("texmacs" . "TeXmacs"))) - - (or (assoc-ref quirks project) project)) - -(define (releases project) - "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]|[^-])*(-src)?\\.tar\\."))) - - (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; 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) - (format (current-error-port) - "failed to get release list for `~A': ~S ~S~%" - project message args) - '()))) - -(define version-string>? - (let ((strverscmp - (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) - (error "could not find `strverscmp' (from GNU libc)")))) - (pointer->procedure int sym (list '* '*))))) - (lambda (a b) - (> (strverscmp (string->pointer a) (string->pointer b)) 0)))) - -(define (latest-release project) - "Return (\"FOO-X.Y\" . \"/bar/foo\") or #f." - (let ((releases (releases project))) - (and (not (null? releases)) - (fold (lambda (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) - "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) - (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)))) - (if (not latest) - (begin - (format #t "~A [unknown latest version]~%" - name+version) - result) - (match (unpack latest) - ((_ (? (cut string=? old-version <>)) _) - (format #t "~A [up to date]~%" name+version) - result) - ((project new-version directory) - (let-values (((old-name old-hash old-urls) - (src->values src))) - (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 directory - 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 directory version archive-type) - "Download PROJECT's tarball over FTP." - (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"))) - (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 (gnupg-verify* sig path))) - (false-if-exception (delete-file sig)) - (if 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 " -A, --attribute=ATTR~%") - (format #t " Update only the package pointed to by attribute~%") - (format #t " ATTR.~%") - (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 ~%") - (exit 0))) - (option '(#\A "attribute") #t #f - (lambda (opt name arg result) - (alist-cons 'attribute arg result))) - (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. - - (define (nixpkgs->snix xml-file attribute) - (format (current-error-port) "evaluating Nixpkgs...~%") - (let* ((home (getenv "HOME")) - (xml (if xml-file - (open-input-file xml-file) - (open-nixpkgs (or (getenv "NIXPKGS") - (string-append home "/src/nixpkgs")) - attribute))) - (snix (xml->snix xml))) - (if (not xml-file) - (let ((status (pipe-failed? xml))) - (if status - (begin - (format (current-error-port) "`nix-instantiate' failed: ~A~%" - status) - (exit 1))))) - - ;; If we asked for a specific attribute, rewrap the thing in an - ;; attribute set to match the expectations of `packages-to-update' & co. - (if attribute - (match snix - (('snix loc ('derivation args ...)) - `(snix ,loc - (attribute-set - ((attribute #f ,attribute - (derivation ,@args))))))) - snix))) - - (define (selected-gnu-packages packages stdenv selection) - ;; Return the subset of PACKAGES that are/aren't in STDENV, according to - ;; SELECTION. To do that reliably, we check whether their "src" - ;; derivation is a requisite of STDENV. - (define gnu - (gnu-packages packages)) - - (case selection - ((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))) - - (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)) - '())) - (snix (nixpkgs->snix (assq-ref opts 'xml-file) - (assq-ref opts 'attribute))) - (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))))) - (attribute (assq-ref opts 'attribute)) - (selection (assq-ref opts 'filter)) - (to-update (if attribute - packages ; already a subset - (selected-gnu-packages packages stdenv selection))) - (updates (packages-to-update to-update))) - - (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)) - -;;; Local Variables: -;;; eval: (put 'call-with-package 'scheme-indent-function 1) -;;; End: