Add (guix zlib).

* guix/zlib.scm, tests/zlib.scm: New files. * Makefile.am (MODULES): Add guix/zlib.scm. (SCM_TESTS): Add tests/zlib.scm. * m4/guix.m4 (GUIX_LIBGCRYPT_LIBDIR): New macro. * configure.ac (LIBGCRYPT_LIBDIR): Use it. Define and substitute 'LIBZ'. * guix/config.scm.in (%libz): New variable.
5 years ago · 721539026d
7 changed files with 328 additions and 1 deletions
--- 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))
--- 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				\
--- 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])
--- 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@")

--- a/guix/zlib.scm
+++ 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
--- 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
--- a/tests/zlib.scm
+++ 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)