guix/zlib.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 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 (close-procedure gzfile port)
 153   "Return a procedure that closes GZFILE, ensuring its underlying PORT is
 154 closed even if closing GZFILE triggers an exception."
 155   (let-syntax ((ignore-EBADF
 156                 (syntax-rules ()
 157                   ((_ exp)
 158                    (catch 'system-error
 159                      (lambda ()
 160                        exp)
 161                      (lambda args
 162                        (unless (= EBADF (system-error-errno args))
 163                          (apply throw args))))))))
 164
 165     (lambda ()
 166       (catch 'zlib-error
 167         (lambda ()
 168           ;; 'gzclose' closes the underlying file descriptor.  'close-port'
 169           ;; calls close(2) and gets EBADF, which we swallow.
 170           (gzclose gzfile)
 171           (ignore-EBADF (close-port port)))
 172         (lambda args
 173           ;; Make sure PORT is closed despite the zlib error.
 174           (ignore-EBADF (close-port port))
 175           (apply throw args))))))
 176
 177 (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
 178   "Return an input port that decompresses data read from PORT, a file port.
 179 PORT is automatically closed when the resulting port is closed.  BUFFER-SIZE
 180 is the size in bytes of the internal buffer, 8 KiB by default; using a larger
 181 buffer increases decompression speed.  An error is thrown if PORT contains
 182 buffered input, which would be lost (and is lost anyway)."
 183   (define gzfile
 184     (match (drain-input port)
 185       (""                                         ;PORT's buffer is empty
 186        (gzdopen (fileno port) "r"))
 187       (_
 188        ;; This is unrecoverable but it's better than having the buffered input
 189        ;; be lost, leading to unclear end-of-file or corrupt-data errors down
 190        ;; the path.
 191        (throw 'zlib-error 'make-gzip-input-port
 192               "port contains buffered input" port))))
 193
 194   (define (read! bv start count)
 195     (gzread! gzfile bv start count))
 196
 197   (unless (= buffer-size %default-buffer-size)
 198     (gzbuffer! gzfile buffer-size))
 199
 200   (make-custom-binary-input-port "gzip-input" read! #f #f
 201                                  (close-procedure gzfile port)))
 202
 203 (define* (make-gzip-output-port port
 204                                 #:key
 205                                 (level %default-compression-level)
 206                                 (buffer-size %default-buffer-size))
 207   "Return an output port that compresses data at the given LEVEL, using PORT,
 208 a file port, as its sink.  PORT is automatically closed when the resulting
 209 port is closed."
 210   (define gzfile
 211     (begin
 212       (force-output port)                         ;empty PORT's buffer
 213       (gzdopen (fileno port)
 214                (string-append "w" (number->string level)))))
 215
 216   (define (write! bv start count)
 217     (gzwrite gzfile bv start count))
 218
 219   (unless (= buffer-size %default-buffer-size)
 220     (gzbuffer! gzfile buffer-size))
 221
 222   (make-custom-binary-output-port "gzip-output" write! #f #f
 223                                   (close-procedure gzfile port)))
 224
 225 (define* (call-with-gzip-input-port port proc
 226                                     #:key (buffer-size %default-buffer-size))
 227   "Call PROC with a port that wraps PORT and decompresses data read from it.
 228 PORT is closed upon completion.  The gzip internal buffer size is set to
 229 BUFFER-SIZE bytes."
 230   (let ((gzip (make-gzip-input-port port #:buffer-size buffer-size)))
 231     (dynamic-wind
 232       (const #t)
 233       (lambda ()
 234         (proc gzip))
 235       (lambda ()
 236         (close-port gzip)))))
 237
 238 (define* (call-with-gzip-output-port port proc
 239                                      #:key
 240                                      (level %default-compression-level)
 241                                      (buffer-size %default-buffer-size))
 242   "Call PROC with an output port that wraps PORT and compresses data.  PORT is
 243 close upon completion.  The gzip internal buffer size is set to BUFFER-SIZE
 244 bytes."
 245   (let ((gzip (make-gzip-output-port port
 246                                      #:level level
 247                                      #:buffer-size buffer-size)))
 248     (dynamic-wind
 249       (const #t)
 250       (lambda ()
 251         (proc gzip))
 252       (lambda ()
 253         (close-port gzip)))))
 254
 255 ;;; zlib.scm ends here