diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/union.scm | 66 | ||||
| -rw-r--r-- | guix/derivations.scm | 52 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 138 | ||||
| -rw-r--r-- | guix/snix.scm | 35 |
4 files changed, 259 insertions, 32 deletions
diff --git a/guix/build/union.scm b/guix/build/union.scm index 317c38a1d5..234964dba5 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,9 +19,11 @@ (define-module (guix build union) #:use-module (ice-9 ftw) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (tree-union + delete-duplicate-leaves union-build)) ;;; Commentary: @@ -56,6 +58,48 @@ itself a tree. " '() (delete-duplicates (map car dirs))))))))) +(define* (delete-duplicate-leaves tree + #:optional + (leaf=? equal?) + (delete-duplicates (match-lambda + ((head _ ...) head)))) + "Delete duplicate leaves from TREE. Two leaves are considered equal +when LEAF=? applied to them returns #t. Each collision (list of leaves +that are LEAF=?) is passed to DELETE-DUPLICATES, which must return a +single leaf." + (let loop ((tree tree)) + (match tree + ((dir children ...) + (let ((dirs (filter pair? children)) + (leaves (remove pair? children))) + (define collisions + (fold (lambda (leaf result) + (define same? + (cut leaf=? leaf <>)) + + (if (any (cut find same? <>) result) + result + (match (filter same? leaves) + ((_) + result) + ((collision ...) + (cons collision result))))) + '() + leaves)) + + (define non-collisions + (filter (lambda (leaf) + (match (filter (cut leaf=? leaf <>) leaves) + ((_) #t) + ((_ _ ..1) #f))) + leaves)) + + `(,dir + ,@non-collisions + ,@(map delete-duplicates collisions) + ,@(map loop dirs)))) + (leaf leaf)))) + (define* (union-build output directories) "Build in the OUTPUT directory a symlink tree that is the union of all the DIRECTORIES." @@ -88,12 +132,28 @@ the DIRECTORIES." (((? string?) leaves ...) leaves))) + (define (leaf=? a b) + (equal? (basename a) (basename b))) + + (define (resolve-collision leaves) + ;; LEAVES all have the same basename, so choose one of them. + (format (current-error-port) "warning: collision encountered: ~{~a ~}~%" + leaves) + + ;; TODO: Implement smarter strategies. + (format (current-error-port) "warning: arbitrarily choosing ~a~%" + (car leaves)) + (car leaves)) + (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) (mkdir output) - (let loop ((tree (tree-union (append-map (compose tree-leaves file-tree) - directories))) + (let loop ((tree (delete-duplicate-leaves + (tree-union (append-map (compose tree-leaves file-tree) + directories)) + leaf=? + resolve-collision)) (dir '())) (match tree ((? string?) diff --git a/guix/derivations.scm b/guix/derivations.scm index 7b131955b0..ce8858a2fa 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -112,28 +112,48 @@ download with a fixed hash (aka. `fetchurl')." read-derivation)) inputs))))) -(define (derivation-prerequisites-to-build store drv) - "Return the list of derivation-inputs required to build DRV and not already -available in STORE, recursively." +(define* (derivation-prerequisites-to-build store drv + #:key (outputs + (map + car + (derivation-outputs drv)))) + "Return the list of derivation-inputs required to build the OUTPUTS of +DRV and not already available in STORE, recursively." + (define built? + (cut valid-path? store <>)) + (define input-built? (match-lambda (($ <derivation-input> path sub-drvs) (let ((out (map (cut derivation-path->output-path path <>) sub-drvs))) - (any (cut valid-path? store <>) out))))) + (any built? out))))) - (let loop ((drv drv) - (result '())) - (let ((inputs (remove (lambda (i) - (or (member i result) ; XXX: quadratic - (input-built? i))) - (derivation-inputs drv)))) - (fold loop - (append inputs result) - (map (lambda (i) - (call-with-input-file (derivation-input-path i) - read-derivation)) - inputs))))) + (define (derivation-built? drv sub-drvs) + (match drv + (($ <derivation> outputs) + (let ((paths (map (lambda (sub-drv) + (derivation-output-path + (assoc-ref outputs sub-drv))) + sub-drvs))) + (every built? paths))))) + + (let loop ((drv drv) + (sub-drvs outputs) + (result '())) + (if (derivation-built? drv sub-drvs) + result + (let ((inputs (remove (lambda (i) + (or (member i result) ; XXX: quadratic + (input-built? i))) + (derivation-inputs drv)))) + (fold loop + (append inputs result) + (map (lambda (i) + (call-with-input-file (derivation-input-path i) + read-derivation)) + inputs) + (map derivation-input-sub-derivations inputs)))))) (define (read-derivation drv-port) "Read the derivation from DRV-PORT and return the corresponding diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 87ef427481..c934694147 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,10 +22,28 @@ #:use-module (web client) #:use-module (web response) #:use-module (ice-9 regex) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:export (official-gnu-packages)) + #:use-module (system foreign) + #:use-module (guix ftp-client) + #:export (official-gnu-packages + releases + latest-release + gnu-package-name->name+version)) + +;;; Commentary: +;;; +;;; Code for dealing with the maintenance of GNU packages, such as +;;; auto-updates. +;;; +;;; Code: + + +;;; +;;; List of GNU packages. +;;; (define (http-fetch uri) "Return a string containing the textual data at URI, a string." @@ -55,3 +73,119 @@ (and=> (regexp-exec %package-line-rx line) (cut match:substring <> 1))) lst))) + +;;; +;;; Latest release. +;;; + +(define (ftp-server/directory project) + "Return the FTP server and directory where PROJECT's tarball are +stored." + (define quirks + '(("commoncpp2" "ftp.gnu.org" "/gnu/commoncpp") + ("ucommon" "ftp.gnu.org" "/gnu/commoncpp") + ("libzrtpcpp" "ftp.gnu.org" "/gnu/ccrtp") + ("libosip2" "ftp.gnu.org" "/gnu/osip") + ("libgcrypt" "ftp.gnupg.org" "/gcrypt/libgcrypt") + ("libgpg-error" "ftp.gnupg.org" "/gcrypt/libgpg-error") + ("libassuan" "ftp.gnupg.org" "/gcrypt/libassuan") + ("gnupg" "ftp.gnupg.org" "/gcrypt/gnupg") + ("freefont-ttf" "ftp.gnu.org" "/gnu/freefont") + ("gnu-ghostscript" "ftp.gnu.org" "/gnu/ghostscript") + ("mit-scheme" "ftp.gnu.org" "/gnu/mit-scheme/stable.pkg") + ("icecat" "ftp.gnu.org" "/gnu/gnuzilla") + ("source-highlight" "ftp.gnu.org" "/gnu/src-highlite") + ("TeXmacs" "ftp.texmacs.org" "/TeXmacs/targz"))) + + (match (assoc project quirks) + ((_ server directory) + (values server directory)) + (_ + (values "ftp.gnu.org" (string-append "/gnu/" 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))) + + (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))))))) + +(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) + "Return #t when B denotes a newer version than A." + (> (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 (gnu-package-name->name+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))))) + +;;; gnu-maintenance.scm ends here diff --git a/guix/snix.scm b/guix/snix.scm index c90893bdfe..977898989b 100644 --- a/guix/snix.scm +++ b/guix/snix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -366,15 +366,18 @@ location of DERIVATION." attribute-value) (#f '()) - ((('derivation _ _ (attributes ...)) ...) - (map (lambda (attrs) - (let* ((full-name (attribute-value - (find-attribute-by-name "name" attrs))) - (name (package-name->name+version full-name))) - (list name - (list 'unquote - (string->symbol name))))) - attributes)))) + ((inputs ...) + ;; Inputs can be either derivations or the null value. + (filter-map (match-lambda + (('derivation _ _ (attributes ...)) + (let* ((full-name + (attribute-value + (find-attribute-by-name "name" attributes))) + (name (package-name->name+version full-name))) + (list name + (list 'unquote (string->symbol name))))) + ('null #f)) + inputs)))) (define (maybe-inputs guix-name inputs) (match inputs @@ -390,6 +393,16 @@ location of DERIVATION." `(string-append ,@items)) (x x))) + (define (license-variable license) + ;; Return the name of the (guix licenses) variable for LICENSE. + (match license + ("GPLv2+" 'gpl2+) + ("GPLv3+" 'gpl3+) + ("LGPLv2+" 'lgpl2.1+) + ("LGPLv2.1+" 'lgpl2.1+) + ("LGPLv3+" 'lgpl3+) + (_ license))) + (let* ((source (find-attribute-by-name "src" attributes)) (urls (source-urls source)) (sha256 (source-sha256 source)) @@ -423,7 +436,7 @@ location of DERIVATION." ,(and=> (find-attribute-by-name "longDescription" meta) attribute-value)) (license ,(and=> (find-attribute-by-name "license" meta) - attribute-value))) + (compose license-variable attribute-value)))) loc)))))) (define (nixpkgs->guix-package nixpkgs attribute) |