| 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 |