guix/zlib.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix zlib)
  20   #:use-module (rnrs bytevectors)
  21   #:use-module (ice-9 binary-ports)
  22   #:use-module (ice-9 match)
  23   #:use-module (system foreign)
  24   #:use-module (guix config)
  25   #:export (zlib-available?
  26             make-gzip-input-port
  27             make-gzip-output-port
  28             call-with-gzip-input-port
  29             call-with-gzip-output-port
  30             %default-buffer-size
  31             %default-compression-level))
  32
  33 ;;; Commentary:
  34 ;;;
  35 ;;; Bindings to the gzip-related part of zlib's API.  The main limitation of
  36 ;;; this API is that it requires a file descriptor as the source or sink.
  37 ;;;
  38 ;;; Code:
  39
  40 (define %zlib
  41   ;; File name of zlib's shared library.  When updating via 'guix pull',
  42   ;; '%libz' might be undefined so protect against it.
  43   (delay (dynamic-link (if (defined? '%libz)
  44                            %libz
  45                            "libz"))))
  46
  47 (define (zlib-available?)
  48   "Return true if zlib is available, #f otherwise."
  49   (false-if-exception (force %zlib)))
  50
  51 (define (zlib-procedure ret name parameters)
  52   "Return a procedure corresponding to C function NAME in libz, or #f if
  53 either zlib or the function could not be found."
  54   (match (false-if-exception (dynamic-func name (force %zlib)))
  55     ((? pointer? ptr)
  56      (pointer->procedure ret ptr parameters))
  57     (#f
  58      #f)))
  59
  60 (define-wrapped-pointer-type <gzip-file>
  61   ;; Scheme counterpart of the 'gzFile' opaque type.
  62   gzip-file?
  63   pointer->gzip-file
  64   gzip-file->pointer
  65   (lambda (obj port)
  66     (format port "#<gzip-file ~a>"
  67             (number->string (object-address obj) 16))))
  68
  69 (define gzerror
  70   (let ((proc (zlib-procedure '* "gzerror" '(* *))))
  71     (lambda (gzfile)
  72       (let* ((errnum* (make-bytevector (sizeof int)))
  73              (ptr     (proc (gzip-file->pointer gzfile)
  74                             (bytevector->pointer errnum*))))
  75         (values (bytevector-sint-ref errnum* 0
  76                                      (native-endianness) (sizeof int))
  77                 (pointer->string ptr))))))
  78
  79 (define gzdopen
  80   (let ((proc (zlib-procedure '* "gzdopen" (list int '*))))
  81     (lambda (fd mode)
  82       "Open file descriptor FD as a gzip stream with the given MODE.  MODE must
  83 be a string denoting the how FD is to be opened, such as \"r\" for reading or
  84 \"w9\" for writing data compressed at level 9 to FD.  Calling 'gzclose' also
  85 closes FD."
  86       (let ((result (proc fd (string->pointer mode))))
  87         (if (null-pointer? result)
  88             (throw 'zlib-error 'gzdopen)
  89             (pointer->gzip-file result))))))
  90
  91 (define gzread!
  92   (let ((proc (zlib-procedure int "gzread" (list '* '* unsigned-int))))
  93     (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
  94       "Read up to COUNT bytes from GZFILE into BV at offset START.  Return the
  95 number of uncompressed bytes actually read; it is zero if COUNT is zero or if
  96 the end-of-stream has been reached."
  97       (let ((ret (proc (gzip-file->pointer gzfile)
  98                        (bytevector->pointer bv start)
  99                        count)))
 100         (if (< ret 0)
 101             (throw 'zlib-error 'gzread! ret)
 102             ret)))))
 103
 104 (define gzwrite
 105   (let ((proc (zlib-procedure int "gzwrite" (list '* '* unsigned-int))))
 106     (lambda* (gzfile bv #:optional (start 0) (count (bytevector-length bv)))
 107       "Write up to COUNT bytes from BV at offset START into GZFILE.  Return
 108 the number of uncompressed bytes written, a strictly positive integer."
 109       (let ((ret (proc (gzip-file->pointer gzfile)
 110                        (bytevector->pointer bv start)
 111                        count)))
 112         (if (<= ret 0)
 113             (throw 'zlib-error 'gzwrite ret)
 114             ret)))))
 115
 116 (define gzbuffer!
 117   (let ((proc (zlib-procedure int "gzbuffer" (list '* unsigned-int))))
 118     (lambda (gzfile size)
 119       "Change the internal buffer size of GZFILE to SIZE bytes."
 120       (let ((ret (proc (gzip-file->pointer gzfile) size)))
 121         (unless (zero? ret)
 122           (throw 'zlib-error 'gzbuffer! ret))))))
 123
 124 (define gzeof?
 125   (let ((proc (zlib-procedure int "gzeof" '(*))))
 126     (lambda (gzfile)
 127       "Return true if the end-of-file has been reached on GZFILE."
 128       (not (zero? (proc (gzip-file->pointer gzfile)))))))
 129
 130 (define gzclose
 131   (let ((proc (zlib-procedure int "gzclose" '(*))))
 132     (lambda (gzfile)
 133       "Close GZFILE."
 134       (let ((ret (proc (gzip-file->pointer gzfile))))
 135         (unless (zero? ret)
 136           (throw 'zlib-error 'gzclose ret (gzerror gzfile)))))))
 137
 138
 139 \f
 140 ;;;
 141 ;;; Port interface.
 142 ;;;
 143
 144 (define %default-buffer-size
 145   ;; Default buffer size, as documented in <zlib.h>.
 146   8192)
 147
 148 (define %default-compression-level
 149   ;; Z_DEFAULT_COMPRESSION.
 150   -1)
 151
 152 (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
 153   "Return an input port that decompresses data read from PORT, a file port.
 154 PORT is automatically closed when the resulting port is closed.  BUFFER-SIZE
 155 is the size in bytes of the internal buffer, 8 KiB by default; using a larger
 156 buffer increases decompression speed.  An error is thrown if PORT contains
 157 buffered input, which would be lost (and is lost anyway)."
 158   (define gzfile
 159     (match (drain-input port)
 160       (""                                         ;PORT's buffer is empty
 161        ;; 'gzclose' will eventually close the file descriptor beneath PORT.
 162        ;; 'close-port' on PORT would get EBADF if 'gzclose' already closed it,
 163        ;; so that's no good; revealed ports are no good either because they
 164        ;; leak (see <https://bugs.gnu.org/28784>); calling 'close-port' after
 165        ;; 'gzclose' doesn't work either because it leads to a race condition
 166        ;; (see <https://bugs.gnu.org/29335>).  So we dup and close PORT right
 167        ;; away.
 168        (gzdopen (dup (fileno port)) "r"))
 169       (_
 170        ;; This is unrecoverable but it's better than having the buffered input
 171        ;; be lost, leading to unclear end-of-file or corrupt-data errors down
 172        ;; the path.
 173        (throw 'zlib-error 'make-gzip-input-port
 174               "port contains buffered input" port))))
 175
 176   (define (read! bv start count)
 177     (gzread! gzfile bv start count))
 178
 179   (unless (= buffer-size %default-buffer-size)
 180     (gzbuffer! gzfile buffer-size))
 181
 182   (close-port port)                               ;we no longer need it
 183   (make-custom-binary-input-port "gzip-input" read! #f #f
 184                                  (lambda ()
 185                                    (gzclose gzfile))))
 186
 187 (define* (make-gzip-output-port port
 188                                 #:key
 189                                 (level %default-compression-level)
 190                                 (buffer-size %default-buffer-size))
 191   "Return an output port that compresses data at the given LEVEL, using PORT,
 192 a file port, as its sink.  PORT is automatically closed when the resulting
 193 port is closed."
 194   (define gzfile
 195     (begin
 196       (force-output port)                         ;empty PORT's buffer
 197       (gzdopen (dup (fileno port))
 198                (string-append "w" (number->string level)))))
 199
 200   (define (write! bv start count)
 201     (gzwrite gzfile bv start count))
 202
 203   (unless (= buffer-size %default-buffer-size)
 204     (gzbuffer! gzfile buffer-size))
 205
 206   (close-port port)
 207   (make-custom-binary-output-port "gzip-output" write! #f #f
 208                                   (lambda ()
 209                                     (gzclose gzfile))))
 210
 211 (define* (call-with-gzip-input-port port proc
 212                                     #:key (buffer-size %default-buffer-size))
 213   "Call PROC with a port that wraps PORT and decompresses data read from it.
 214 PORT is closed upon completion.  The gzip internal buffer size is set to
 215 BUFFER-SIZE bytes."
 216   (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
 217     (dynamic-wind
 218       (const #t)
 219       (lambda ()
 220         (proc gzip))
 221       (lambda ()
 222         (close-port gzip)))))
 223
 224 (define* (call-with-gzip-output-port port proc
 225                                      #:key
 226                                      (level %default-compression-level)
 227                                      (buffer-size %default-buffer-size))
 228   "Call PROC with an output port that wraps PORT and compresses data.  PORT is
 229 close upon completion.  The gzip internal buffer size is set to BUFFER-SIZE
 230 bytes."
 231   (let ((gzip (make-gzip-output-port port
 232                                      #:level level
 233                                      #:buffer-size buffer-size)))
 234     (dynamic-wind
 235       (const #t)
 236       (lambda ()
 237         (proc gzip))
 238       (lambda ()
 239         (close-port gzip)))))
 240
 241 ;;; zlib.scm ends here