nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add (guix build union). 

* guix/build/union.scm, tests/union.scm: New files.
* Makefile.am (MODULES): Add `guix/build/union.scm'.
  (TESTS): Add `tests/union.scm'.
This commit is contained in:
Ludovic Courtès 2012-10-29 22:39:46 +01:00
parent 48da001fd9
commit c8c88afaa1
3 changed files with 222 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile.am
View File

@ -34,6 +34,7 @@ MODULES = \
guix/build/ftp.scm \ guix/build/ftp.scm \
guix/build/http.scm \ guix/build/http.scm \
guix/build/utils.scm \ guix/build/utils.scm \
guix/build/union.scm \
guix/packages.scm \ guix/packages.scm \
guix.scm \ guix.scm \
distro.scm \ distro.scm \
@ -116,7 +117,8 @@ TESTS = \
tests/derivations.scm \ tests/derivations.scm \
tests/utils.scm \ tests/utils.scm \
tests/build-utils.scm \ tests/build-utils.scm \
tests/packages.scm tests/packages.scm \
tests/union.scm
LOG_COMPILER = \ LOG_COMPILER = \
$(top_builddir)/pre-inst-env \ $(top_builddir)/pre-inst-env \

116
guix/build/union.scm Normal file
View File

@ -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

103
tests/union.scm Normal file
View File

@ -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: