diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | guix/build/union.scm | 116 | ||||
| -rw-r--r-- | tests/union.scm | 103 |
3 files changed, 222 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 10f3b61702..75e479ddc4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -34,6 +34,7 @@ MODULES = \ guix/build/ftp.scm \ guix/build/http.scm \ guix/build/utils.scm \ + guix/build/union.scm \ guix/packages.scm \ guix.scm \ distro.scm \ @@ -116,7 +117,8 @@ TESTS = \ tests/derivations.scm \ tests/utils.scm \ tests/build-utils.scm \ - tests/packages.scm + tests/packages.scm \ + tests/union.scm LOG_COMPILER = \ $(top_builddir)/pre-inst-env \ diff --git a/guix/build/union.scm b/guix/build/union.scm new file mode 100644 index 0000000000..ffd367917a --- /dev/null +++ b/guix/build/union.scm @@ -0,0 +1,116 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; Guix 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. +;;; +;;; Guix 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 Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build union) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (tree-union + union-build)) + +;;; Commentary: +;;; +;;; Build a directory that is the union of a set of directories, using +;;; symbolic links. +;;; +;;; Code: + +(define (tree-union trees) + "Return a tree that is the union of the trees listed in TREES. Each +tree has the form (PARENT LEAVES ...) or just LEAF, where each leaf is +itself a tree. " + (let loop ((trees trees)) + (match trees + (() ; nothing left + '()) + (_ + (let ((dirs (filter pair? trees)) + (leaves (remove pair? trees))) + `(,@leaves + ,@(fold (lambda (dir result) + (cons `(,dir + ,@(loop + (concatenate + (filter-map (match-lambda + ((head children ...) + (and (equal? head dir) + children))) + dirs)))) + result)) + '() + (delete-duplicates (map car dirs))))))))) + +(define* (union-build output directories) + "Build in the OUTPUT directory a symlink tree that is the union of all +the DIRECTORIES." + (define (file-tree dir) + ;; Return the contents of DIR as a tree. + (match (file-system-fold (const #t) + (lambda (file stat result) ; leaf + (match result + (((siblings ...) rest ...) + `((,file ,@siblings) ,@rest)))) + (lambda (dir stat result) ; down + `(() ,@result)) + (lambda (dir stat result) ; up + (match result + (((leaves ...) (siblings ...) rest ...) + `(((,(basename dir) ,@leaves) ,@siblings) + ,@rest)))) + (const #f) ; skip + (lambda (file stat errno result) + (format (current-error-port) "union-build: ~a: ~a~%" + file (strerror errno))) + '(()) + dir) + (((tree)) tree) + (() #f))) + + (define tree-leaves + ;; Return the leaves of the given tree. + (match-lambda + (((? string?) leaves ...) + 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))) + (dir '())) + (match tree + ((? string?) + ;; A leaf: create a symlink. + (let* ((dir (string-join dir "/")) + (target (string-append output "/" dir "/" (basename tree)))) + (format (current-error-port) "`~a' ~~> `~a'~%" + tree target) + (symlink tree target))) + (((? string? subdir) leaves ...) + ;; A sub-directory: create it in OUTPUT, and iterate over LEAVES. + (let ((dir (string-join dir "/"))) + (mkdir (string-append output "/" dir "/" subdir))) + (for-each (cute loop <> `(,@dir ,subdir)) + leaves)) + ((leaves ...) + ;; A series of leaves: iterate over them. + (for-each (cut loop <> dir) leaves))))) + +;;; union.scm ends here diff --git a/tests/union.scm b/tests/union.scm new file mode 100644 index 0000000000..f8a58d5952 --- /dev/null +++ b/tests/union.scm @@ -0,0 +1,103 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; Guix 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. +;;; +;;; Guix 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 Guix. If not, see <http://www.gnu.org/licenses/>. + + +(define-module (test-union) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix build union) + #:use-module ((guix build utils) + #:select (with-directory-excursion directory-exists?)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +;; Exercise the (guix build union) module. + +(define %store + (false-if-exception (open-connection))) + +(define %bootstrap-guile + (@@ (distro packages base) %bootstrap-guile)) + +(when %store + ;; By default, use %BOOTSTRAP-GUILE for the current system. + (let ((drv (package-derivation %store %bootstrap-guile))) + (%guile-for-build drv))) + + +(test-begin "union") + +(test-equal "tree-union, empty" + '() + (tree-union '())) + +(test-equal "tree-union, leaves only" + '(a b c d) + (tree-union '(a b c d))) + +(test-equal "tree-union, simple" + '((bin ls touch make awk gawk)) + (tree-union '((bin ls touch) + (bin make) + (bin awk gawk)))) + +(test-equal "tree-union, several levels" + '((share (doc (make README) (coreutils README))) + (bin ls touch make)) + (tree-union '((bin ls touch) + (share (doc (coreutils README))) + (bin make) + (share (doc (make README)))))) + +(test-skip (if %store 0 1)) + +(test-assert "union-build" + (let* ((inputs (map (match-lambda + ((name package) + `(,name ,(package-derivation %store package)))) + (@@ (distro packages base) %bootstrap-inputs))) + (builder `(begin + (use-modules (guix build union)) + (union-build (assoc-ref %outputs "out") + (map cdr %build-inputs)))) + (drv + (build-expression->derivation %store "union-test" + (%current-system) + builder inputs + #:modules '((guix build union))))) + (and (build-derivations %store (list (pk 'drv drv))) + (with-directory-excursion (derivation-path->output-path drv) + (and (file-exists? "bin/touch") + (file-exists? "bin/gcc") + (file-exists? "bin/ld") + (file-exists? "lib/libc.so") + (directory-exists? "lib/gcc") + (file-exists? "include/unistd.h")))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'test-assert 'scheme-indent-function 1) +;;; eval: (put 'test-equal 'scheme-indent-function 1) +;;; eval: (put 'call-with-input-string 'scheme-indent-function 1) +;;; End: |