[guile-zlib] Bind the uncompress function

1 files changed, 142 insertions, 0 deletions

diff --git a/gnu/gnunet/utils/decompress.scm b/gnu/gnunet/utils/decompress.scm
new file mode 100644
index 0000000..03a4a43
--- /dev/null
+++ b/gnu/gnunet/utils/decompress.scm
@@ -0,0 +1,142 @@
+;;; Zlib bindings, adapted from Guile-zlib
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
+;;; Copyright © 2020 Maxime Devos <maxime.devos@student.kuleuven.be>
+;;;
+;;; This file is part of Guile-zlib.
+;;;
+;;; Guile-zlib 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.
+;;;
+;;; Guile-zlib 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 Guile-zlib.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; This file is extracted from Guile-zlib, which was extracted from Guix
+;;; and originally writen by Ludovic Courtès.
+;;; Bindings to the gzip-related part of zlib's API.  The main limitation of
+;;; this API is that it requires a bytevector as the source or sink.
+;;;
+;;; Code:
+
+(library (gnu gnunet utils decompress)
+  (export decompress)
+  (import (system foreign)
+          (only (guile) dynamic-link false-if-exception
+                dynamic-func)
+          (only (ice-9 match) match)
+          (only (srfi srfi-45) delay force)
+          (only (zlib config) %libz)
+          (rnrs base)
+          (rnrs control)
+          (rnrs exceptions)
+          (rnrs bytevectors)
+          (rnrs conditions))
+
+  (define %zlib
+    (delay (dynamic-link %libz)))
+
+  (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-condition-type &z-error &error
+    make-z-error z-error?)
+  (define-condition-type &z-oom-error &z-error
+    make-z-oom-error z-oom-error?)
+  (define-condition-type &z-buf-error &z-error
+    make-z-buf-error z-buf-error?)
+  (define-condition-type &z-data-error &z-error
+    make-z-data-error z-data-error?)
+  (define-condition-type &z-bogus-error &violation
+    make-z-bogus-error z-bogus-error?
+    (value z-bogus-error-value))
+
+  (define Z_OK 0)
+  (define Z_DATA_ERROR -3)
+  (define Z_MEM_ERROR -4)
+  (define Z_BUF_ERROR -5)
+
+  (define uncompress!
+    (let ((proc (zlib-procedure int "uncompress" `(* * * ,unsigned-long))))
+      (lambda (dest-bv dest-offset dest-length
+                       source-bv source-offset source-length)
+        "Uncompress the source buffer into the destination buffer.
+
+Return the actual buffer size on success, raise an appropriate
+&z-error otherwise.
+
+&z-oom-error: out of memory
+&z-data-error: corrupted or incomplete data
+&z-buf-error: output buffer too small
+
+@var{dest-bv}: destination buffer, as a bytevector
+@var{dest-offset}: position of the first byte in @var{dest-bv}
+@var{dest-length}: size of @var{dest-bv}. Possibly more than
+strictly required."
+        ;; Verify bounds
+        (assert (and (exact? dest-offset)
+                     (integer? dest-offset)))
+        (assert (and (exact? dest-length)
+                     (integer? dest-length)))
+        (assert (and (exact? source-offset)
+                     (integer? source-offset)))
+        (assert (and (exact? source-length)
+                     (integer? source-length)))
+        (assert (and (<= 0 dest-offset)
+                     (<= dest-offset (bytevector-length dest-bv))))
+        (assert (and (<= 0 source-offset)
+                     (<= source-offset (bytevector-length source-bv))))
+        (assert (and (<= (+ source-offset source-length)
+                         (bytevector-length source-bv))))
+        (assert (and (<= (+ dest-offset dest-length)
+                         (bytevector-length dest-bv))))
+        (let* ((dest-len-buf
+                (make-c-struct `(,unsigned-long) `(,dest-length)))
+               (ret (proc (bytevector->pointer dest-bv dest-offset)
+                          dest-len-buf
+                          (bytevector->pointer source-bv source-offset)
+                          source-length)))
+          (cond ((= ret Z_OK)
+                 (list-ref (parse-c-struct dest-len-buf `(,unsigned-long))
+                           0))
+                ((= ret Z_MEM_ERROR) (raise (make-z-oom-error)))
+                ((= ret Z_BUF_ERROR) (raise (make-z-buf-error)))
+                ((= ret Z_DATA_ERROR) (raise (make-z-data-error)))
+                (else (raise
+                       (condition
+                        (make-z-bogus-error ret)
+                        (make-message-condition "bogus zlib error value")
+                        (make-who-condition 'uncompress!)))))))))
+
+  (define decompress
+    (case-lambda
+      "Uncompress a bytevector with deflate"
+      ((input-size output-size input-bv)
+       (decompress input-size output-size input-bv 0))
+      ((input-size output-size input-bv input-offset)
+       "Decompress a source buffer
+
+Return the decompressed buffer as a fresh bytevector.
+In case the input is invalid, return #f"
+       (guard (ex ((z-buf-error? ex) #f)
+                  ((z-data-error? ex) #f))
+         (let* ((bv (make-bytevector output-size))
+                (bv-used (uncompress! bv 0 output-size input-bv input-offset
+                                      input-size)))
+           (and (= bv-used output-size)
+                bv)))))))
+