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