#!/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 <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")))
(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 <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))))
;; 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 <http://article.gmane.org/gmane.linux.distributions.nixos/5946>.)
;; 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 <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)
(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 <ludo@gnu.org>~%")
(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: