Disarchive/tests/kinds/tar-extension.scm

;;; Disarchive
;;; Copyright © 2020, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Disarchive.
;;;
;;; Disarchive 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.
;;;
;;; Disarchive 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 Disarchive.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (disarchive kinds tar-extension)
             (disarchive kinds zero-string)
             (disarchive serialization)
             (quickcheck)
             (quickcheck arbitrary)
             (quickcheck property)
             (rnrs bytevectors)
             (srfi srfi-64)
             (tests kinds))

(define (bytevector-take bv k)
  (let ((bv* (make-bytevector k)))
    (bytevector-copy! bv 0 bv* 0 k)
    bv*))

(configure-quickcheck
 ;; Perform 1000 tests per property...
 (stop? (lambda (success-count _)
          (>= success-count 1000)))
 ;; ...over input sizes from 0 to 100.
 (size (lambda (test-number)
         (if (zero? test-number) 0 (1+ (quotient test-number 10))))))

(test-begin "kinds--tar-extension")

(test-equal "Reads a single pax record"
  `(("foo" . "bar"))
  (decode-pax-records (string->utf8 "11 foo=bar\n")))

(test-equal "Reads multiple pax records"
  `(("foo" . "bar") ("baz" . "quux"))
  (decode-pax-records (string->utf8 "11 foo=bar\n12 baz=quux\n")))

(test-equal "Gives up on malformed pax record"
  (list (string->utf8 "123abc"))
  (decode-pax-records (string->utf8 "123abc")))

(test-equal "Reads until malformed pax record"
  `(("foo" . "bar") ,(string->utf8 "123abc"))
  (decode-pax-records (string->utf8 "11 foo=bar\n123abc")))

(test-equal "Reads a GNU record"
  `(("path" . ,(make-zero-string "foo" "")))
  (decode-gnu-path (string->utf8 "foo\x00")))

(test-assert "[prop] Reading pax is reversible"
  (quickcheck
   (property ((bv $bytevector))
     (let* ((records (decode-pax-records bv))
            (bv* (encode-pax-records records)))
       (equal? bv bv*)))))

(test-assert "[prop] Reading pax is reversible (limited)"
  (quickcheck
   (property ((bv $bytevector)
              (n $byte))
     (let* ((limit (max 0 (- (bytevector-length bv)
                             (quotient n 8))))
            (records (decode-pax-records bv 0 limit))
            (bv* (encode-pax-records records))
            (len (min limit (bytevector-length bv))))
       (equal? (bytevector-take bv len) bv*)))))

(test-assert "[prop] Reading pax records produces a valid result"
  (quickcheck
   (property ((bv $bytevector))
     (valid-pax-records? (decode-pax-records bv)))))

(test-assert "[prop] Reading a GNU path is reversible"
  (quickcheck
   (property ((bv $bytevector))
     (let* ((records (decode-gnu-path bv))
            (bv* (make-bytevector (bytevector-length bv))))
       (encode-gnu-path records bv*)
       (equal? bv bv*)))))

(test-assert "[prop] Reading a GNU path produces a valid result"
  (quickcheck
   (property ((bv $bytevector))
     (valid-gnu-path? (decode-gnu-path bv)))))

(test-assert "[prop] Writing a GNU path is reversible"
  (quickcheck
   (property ((records $gnu-path))
     (test-when (valid-gnu-path? records)
       (equal? records
               (decode-gnu-path (encode-gnu-path records)))))))

(test-assert "[prop] Reading a GNU linkpath is reversible"
  (quickcheck
   (property ((bv $bytevector))
     (let* ((records (decode-gnu-linkpath bv))
            (bv* (make-bytevector (bytevector-length bv))))
       (encode-gnu-linkpath records bv*)
       (equal? bv bv*)))))

(test-assert "[prop] Reading a GNU linkpath produces a valid result"
  (quickcheck
   (property ((bv $bytevector))
     (valid-gnu-linkpath? (decode-gnu-linkpath bv)))))

(test-assert "[prop] Writing a GNU linkpath is reversible"
  (quickcheck
   (property ((records $gnu-linkpath))
     (test-when (valid-gnu-linkpath? records)
       (equal? records
               (decode-gnu-linkpath (encode-gnu-linkpath records)))))))

;; Make the test sizes smaller for these two slow tests.
(configure-quickcheck
 (size (lambda (test-number)
         (if (zero? test-number)
             0
             (1+ (quotient test-number 100))))))

(test-assert "[prop] Writing (simple) pax records is reversible"
  ;; The way that pax records use raw bytevectors as an escape hatch
  ;; makes testing the reversibility of writing very difficult.  We get
  ;; away with it for binary strings because it's easy to check if a
  ;; bytevector is valid UTF-8.  Here, we would have to try and rewrite
  ;; 'get-pax-record', which is just too much work.  Hence, we cheat by
  ;; only checking non-bytevector pax records.
  (quickcheck
   (property ((records $non-bytevector-pax-records))
     (test-when (valid-pax-records? records)
       (equal? records
               (decode-pax-records (encode-pax-records records)))))))

(test-assert "[prop] Serializing pax records is reversible"
  (quickcheck
   (property ((records $pax-records))
     (test-when (valid-pax-records? records)
       (equal? records (serdeser -pax-records- records))))))

(test-end "kinds--tar-extension")