diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | configure.ac | 11 | ||||
| -rw-r--r-- | guix/config.scm.in | 6 | ||||
| -rw-r--r-- | guix/zlib.scm | 234 | ||||
| -rw-r--r-- | m4/guix.m4 | 11 | ||||
| -rw-r--r-- | tests/zlib.scm | 63 |
7 files changed, 328 insertions, 1 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index c7ceb9e9f0..572a35f828 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -41,6 +41,8 @@ (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) (eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2)) (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) + (eval . (put 'call-with-gzip-input-port 'scheme-indent-function 1)) + (eval . (put 'call-with-gzip-output-port 'scheme-indent-function 1)) (eval . (put 'signature-case 'scheme-indent-function 1)) (eval . (put 'emacs-batch-eval 'scheme-indent-function 0)) (eval . (put 'emacs-batch-edit-file 'scheme-indent-function 1)) diff --git a/Makefile.am b/Makefile.am index 37a0aef7dc..576177f6d7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -57,6 +57,7 @@ MODULES = \ guix/licenses.scm \ guix/graph.scm \ guix/cve.scm \ + guix/zlib.scm \ guix/build-system.scm \ guix/build-system/ant.scm \ guix/build-system/cmake.scm \ @@ -258,6 +259,7 @@ SCM_TESTS = \ tests/graph.scm \ tests/challenge.scm \ tests/cve.scm \ + tests/zlib.scm \ tests/file-systems.scm \ tests/system.scm \ tests/services.scm \ diff --git a/configure.ac b/configure.ac index 7c6fcc9ec9..8367b41f3c 100644 --- a/configure.ac +++ b/configure.ac @@ -194,6 +194,17 @@ AC_SUBST([LIBGCRYPT_LIBDIR]) GUIX_ASSERT_LIBGCRYPT_USABLE +dnl Library name of zlib suitable for 'dynamic-link'. +GUIX_LIBZ_LIBDIR([libz_libdir]) +if test "x$libz_libdir" = "x"; then + LIBZ="libz" +else + LIBZ="$libz_libdir/libz" +fi +AC_MSG_CHECKING([for zlib's shared library name]) +AC_MSG_RESULT([$LIBZ]) +AC_SUBST([LIBZ]) + AC_CACHE_SAVE m4_include([config-daemon.ac]) diff --git a/guix/config.scm.in b/guix/config.scm.in index adffa0cfec..6d42cf233c 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +27,7 @@ %guix-register-program %system %libgcrypt + %libz %nix-instantiate %gzip %bzip2 @@ -72,6 +73,9 @@ (define %libgcrypt "@LIBGCRYPT@") +(define %libz + "@LIBZ@") + (define %nix-instantiate "@NIX_INSTANTIATE@") diff --git a/guix/zlib.scm b/guix/zlib.scm new file mode 100644 index 0000000000..51e5e9e426 --- /dev/null +++ b/guix/zlib.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU 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. +;;; +;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix zlib) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (system foreign) + #:use-module (guix config) + #:export (zlib-available? + make-gzip-input-port + make-gzip-output-port + call-with-gzip-input-port + call-with-gzip-output-port + %default-buffer-size + %default-compression-level)) + +;;; Commentary: +;;; +;;; Bindings to the gzip-related part of zlib's API. The main limitation of +;;; this API is that it requires a file descriptor as the source or sink. +;;; +;;; Code: + +(define %zlib + ;; File name of zlib's shared library. When updating via 'guix pull', + ;; '%libz' might be undefined so protect against it. + (delay (dynamic-link (if (defined? '%libz) + %libz + "libz")))) + +(define (zlib-available?) + "Return true if zlib is available, #f otherwise." + (false-if-exception (force %zlib))) + +(define (zlib-procedure ret name parameters) + "Return a procedure corresponding to C function NAME in libz, or #f if +either zlib or the function could not be found." + (match (false-if-exception (dynamic-func name (force %zlib))) + ((? pointer? ptr) + (pointer->procedure ret ptr parameters)) + (#f + #f))) + +(define-wrapped-pointer-type <gzip-file> + ;; Scheme counterpart of the 'gzFile' opaque type. + gzip-file? + pointer->gzip-file + gzip-file->pointer + (lambda (obj port) + (format port "#<gzip-file ~a>" + (number->string (object-address obj) 16)))) + +(define gzerror + (let ((proc (zlib-procedure '* "gzerror" '(* *)))) + (lambda (gzfile) + (let* ((errnum* (make-bytevector (sizeof int))) + (ptr (proc (gzip-file->pointer gzfile) + (bytevector->pointer errnum*)))) + (values (bytevector-sint-ref errnum* 0 + (native-endianness) (sizeof int)) + (pointer->string ptr)))))) + +(define gzdopen + (let ((proc (zlib-procedure '* "gzdopen" (list int '*)))) + (lambda (fd mode) + "Open file descriptor FD as a gzip stream with the given MODE. MODE must +be a string denoting the how FD is to be opened, such as \"r\" for reading or +\"w9\" for writing data compressed at level 9 to FD. Calling 'gzclose' also +closes FD." + (let ((result (proc fd (string->pointer mode)))) + (if (null-pointer? result) + (throw 'zlib-error 'gzdopen) + (pointer->gzip-file result)))))) + +(define gzread! + (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Read up to COUNT bytes from GZFILE into BV at offset START. Return the +number of uncompressed bytes actually read." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (< ret 0) + (throw 'zlib-error 'gzread! ret) + ret))))) + +(define gzwrite + (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int)))) + (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv))) + "Write up to COUNT bytes from BV at offset START into GZFILE. Return +the number of uncompressed bytes written, a strictly positive integer." + (let ((ret (proc (gzip-file->pointer gzfile) + (bytevector->pointer bv start) + count))) + (if (<= ret 0) + (throw 'zlib-error 'gzwrite ret) + ret))))) + +(define gzbuffer! + (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int)))) + (lambda (gzfile size) + "Change the internal buffer size of GZFILE to SIZE bytes." + (let ((ret (proc (gzip-file->pointer gzfile) size))) + (unless (zero? ret) + (throw 'zlib-error 'gzbuffer! ret)))))) + +(define gzeof? + (let ((proc (zlib-procedure int "gzeof" '(*)))) + (lambda (gzfile) + "Return true if the end-of-file has been reached on GZFILE." + (not (zero? (proc (gzip-file->pointer gzfile))))))) + +(define gzclose + (let ((proc (zlib-procedure int "gzclose" '(*)))) + (lambda (gzfile) + "Close GZFILE." + (let ((ret (proc (gzip-file->pointer gzfile)))) + (unless (zero? ret) + (throw 'zlib-error 'gzclose ret (gzerror gzfile))))))) + + + +;;; +;;; Port interface. +;;; + +(define %default-buffer-size + ;; Default buffer size, as documented in <zlib.h>. + 8192) + +(define %default-compression-level + ;; Z_DEFAULT_COMPRESSION. + -1) + +(define (close-procedure gzfile port) + "Return a procedure that closes GZFILE, ensuring its underlying PORT is +closed even if closing GZFILE triggers an exception." + (lambda () + (catch 'zlib-error + (lambda () + ;; 'gzclose' closes the underlying file descriptor. 'close-port' + ;; calls close(2), gets EBADF, which is ignores. + (gzclose gzfile) + (close-port port)) + (lambda args + ;; Make sure PORT is closed despite the zlib error. + (close-port port) + (apply throw args))))) + +(define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) + "Return an input port that decompresses data read from PORT, a file port. +PORT is automatically closed when the resulting port is closed. BUFFER-SIZE +is the size in bytes of the internal buffer, 8 KiB by default; using a larger +buffer increases decompression speed." + (define gzfile + (gzdopen (fileno port) "r")) + + (define (read! bv start count) + ;; XXX: Can 'gzread!' return zero even though we haven't reached the EOF? + (gzread! gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-input-port "gzip-input" read! #f #f + (close-procedure gzfile port))) + +(define* (make-gzip-output-port port + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Return an output port that compresses data at the given LEVEL, using PORT, +a file port, as its sink. PORT is automatically closed when the resulting +port is closed." + (define gzfile + (gzdopen (fileno port) + (string-append "w" (number->string level)))) + + (define (write! bv start count) + (gzwrite gzfile bv start count)) + + (unless (= buffer-size %default-buffer-size) + (gzbuffer! gzfile buffer-size)) + + (make-custom-binary-output-port "gzip-output" write! #f #f + (close-procedure gzfile port))) + +(define* (call-with-gzip-input-port port proc + #:key (buffer-size %default-buffer-size)) + "Call PROC with a port that wraps PORT and decompresses data read from it. +PORT is closed upon completion. The gzip internal buffer size is set to +BUFFER-SIZE bytes." + (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +(define* (call-with-gzip-output-port port proc + #:key + (level %default-compression-level) + (buffer-size %default-buffer-size)) + "Call PROC with an output port that wraps PORT and compresses data. PORT is +close upon completion. The gzip internal buffer size is set to BUFFER-SIZE +bytes." + (let ((gzip (make-gzip-output-port port + #:level level + #:buffer-size buffer-size))) + (dynamic-wind + (const #t) + (lambda () + (proc gzip)) + (lambda () + (close-port gzip))))) + +;;; zlib.scm ends here diff --git a/m4/guix.m4 b/m4/guix.m4 index 2d3dfd282e..a4f83f029a 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -308,6 +308,17 @@ AC_DEFUN([GUIX_LIBGCRYPT_LIBDIR], [ $1="$guix_cv_libgcrypt_libdir" ]) +dnl GUIX_LIBZ_LIBDIR VAR +dnl +dnl Attempt to determine libz's LIBDIR; store the result in VAR. +AC_DEFUN([GUIX_LIBZ_LIBDIR], [ + AC_REQUIRE([PKG_PROG_PKG_CONFIG]) + AC_CACHE_CHECK([zlib's library directory], + [guix_cv_libz_libdir], + [guix_cv_libz_libdir="`$PKG_CONFIG zlib --variable=libdir 2> /dev/null`"]) + $1="$guix_cv_libz_libdir" +]) + dnl GUIX_CURRENT_LOCALSTATEDIR dnl dnl Determine the localstatedir of an existing Guix installation and set diff --git a/tests/zlib.scm b/tests/zlib.scm new file mode 100644 index 0000000000..5455240a71 --- /dev/null +++ b/tests/zlib.scm @@ -0,0 +1,63 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU 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. +;;; +;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-zlib) + #:use-module (guix zlib) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) + +;; Test the (guix zlib) module. + +(unless (zlib-available?) + (exit 77)) + +(test-begin "zlib") + +(test-assert "compression/decompression pipe" + (let ((data (random-bytevector (+ (random 10000) + (* 20 1024))))) + (match (pipe) + ((parent . child) + (match (primitive-fork) + (0 ;compress + (dynamic-wind + (const #t) + (lambda () + (close-port parent) + (call-with-gzip-output-port child + (lambda (port) + (put-bytevector port data)))) + (lambda () + (primitive-exit 0)))) + (pid ;decompress + (begin + (close-port child) + (let ((received (call-with-gzip-input-port parent + (lambda (port) + (get-bytevector-all port)) + #:buffer-size (* 64 1024)))) + (match (waitpid pid) + ((_ . status) + (and (zero? status) + (port-closed? parent) + (bytevector=? received data)))))))))))) + +(test-end) |