nixpkgs-suyu/maintainers/scripts/gnu/gnupdate

#!/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 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 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
           (('good-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))
                         (string-contains value "www.gnu.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)
      ("freefont-ttf" "ftp.gnu.org"   "/gnu/freefont" #f)
      ("gnupg"        "ftp.gnupg.org" "/gcrypt" #t)
      ("gnu-ghostscript" "ftp.gnu.org"  "/gnu/ghostscript" #f)
      ("GNUnet"       "ftp.gnu.org" "/gnu/gnunet" #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")
      ("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)
  "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)
       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: