Disarchive/tests/kinds/xz.scm

;;; Disarchive
;;; Copyright © 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 xz)
             (disarchive utils)
             (quickcheck)
             (quickcheck arbitrary)
             (quickcheck generator)
             (quickcheck property)
             (rnrs bytevectors)
             (srfi srfi-1)
             (srfi srfi-64))

(define-syntax-rule (true-if-exception expr)
  (not (false-if-exception (or expr #t))))

(define ($maybe elem)
  ($choose
   (identity elem)
   (not      ($const #f))))

(define $nibble
  (arbitrary
   (gen (choose-integer 0 15))
   (xform generator-variant)))

(define $uint32
  (arbitrary
   (gen (choose-integer 0 (1- (expt 2 32))))
   (xform generator-variant)))

(define $crc32 ($maybe $uint32))

(define $crc32-bytevector
  (arbitrary
   (gen (choose-bytevector 4))
   (xform (arbitrary-xform $bytevector))))

(define tests-per-property 1000)

(configure-quickcheck
 (stop? (lambda (success-count _)
          (>= success-count tests-per-property))))

(define (test-size-zero-to-ten test-number)
  (if (zero? test-number)
      0
      (1+ (quotient (* test-number 10) tests-per-property))))

(test-begin "kinds--xz")


;; XZ multibyte integers

(define-syntax-rule (bytevector-u8-update! bv index name exp)
  (let ((name (bytevector-u8-ref bv index)))
    (bytevector-u8-set! bv index exp)))

(define (bytevector-ensure-xz-integer! bv)
  (let loop ((k 0))
    (when (< k (bytevector-length bv))
      (if (< k (1- (bytevector-length bv)))
          (bytevector-u8-update! bv k b (logior b #x80))
          (bytevector-u8-update! bv k b (let ((b* (logand b #x7f)))
                                          (if (and (> k 0) (zero? b*))
                                              1
                                              b*))))
      (loop (1+ k)))))

(define $xz-integer $natural)

(define $xz-integer-bytevector
  (arbitrary
   (gen (generator-let* ((bv (sized-generator choose-bytevector)))
          (if (zero? (bytevector-length bv))
              (generator-return #vu8(0))
              (begin
                (bytevector-ensure-xz-integer! bv)
                (generator-return bv)))))
   (xform (arbitrary-xform $bytevector))))

(test-assert "Refuses to decode an XZ integer with high ending"
    (true-if-exception
     (let ((bv #vu8(128)))
       (decode-xz-integer bv))))

(test-assert "Refuses to decode an XZ integer with low middle"
    (true-if-exception
     (let ((bv #vu8(127 128)))
       (decode-xz-integer bv))))

(test-assert "Refuses to decode an XZ integer ending in zero"
    (true-if-exception
     (let ((bv #vu8(128 0)))
       (decode-xz-integer bv))))

(configure-quickcheck
 (size test-size-zero-to-ten))

(test-assert "[prop] Reading XZ integers is reversible"
  (quickcheck
   (property ((bv $xz-integer-bytevector))
     (equal? bv (encode-xz-integer (decode-xz-integer bv))))))

(test-assert "[prop] Writing XZ integers is reversible"
  (quickcheck
   (property ((n $xz-integer))
     (equal? n (decode-xz-integer (encode-xz-integer n))))))


;; XZ stream headers

(define xz-magic-header #vu8(#xfd #x37 #x7a #x58 #x5a #x00))

(define $xz-stream-header
  ($record make-xz-stream-header
    (xz-stream-header-check-type $nibble)
    (xz-stream-header-reserved ($tuple $byte $nibble))
    (xz-stream-header-crc32 $crc32)))

(define (bytevector-set-xz-magic-header! bv)
  (bytevector-copy! xz-magic-header 0 bv 0
                    (min (bytevector-length xz-magic-header)
                         (bytevector-length bv))))

(test-assert "Refuses to decode a small XZ stream header"
  (true-if-exception
   (let ((bv (make-bytevector 10)))
     (bytevector-set-xz-magic-header! bv)
     (decode-xz-stream-header bv))))

(test-assert "Refuses to decode a large XZ stream header"
  (true-if-exception
   (let ((bv (make-bytevector 14)))
     (bytevector-set-xz-magic-header! bv)
     (decode-xz-stream-header bv))))

(test-assert "Refuses to decode XZ stream header without magic"
  (true-if-exception
   (let ((bv (make-bytevector 12)))
     (decode-xz-stream-header bv))))

(test-assert "Does not store a trivial XZ stream header CRC"
  (let ((bv #vu8(0 0 0 0 0 0 1 2 146 66 204 182)))
    (bytevector-set-xz-magic-header! bv)
    (let ((header (decode-xz-stream-header bv)))
      (not (xz-stream-header-crc32 header)))))

(configure-quickcheck
 (size (const 12)))

(test-assert "[prop] Reading XZ stream headers is reversible"
  (quickcheck
   (property ((bv $bytevector))
     (bytevector-set-xz-magic-header! bv)
     (equal? bv (encode-xz-stream-header (decode-xz-stream-header bv))))))

(test-assert "[prop] Writing XZ stream headers is reversible"
  (quickcheck
   (property ((header $xz-stream-header))
     (let ((bv (encode-xz-stream-header header)))
       ;; If we happen to generate a header with the correct CRC, it
       ;; will become #f when we decode it.
       (test-when (not (and=> (xz-stream-header-crc32 header)
                              (lambda (crc32)
                                (= crc32 (bytevector-xz-crc32 bv 6 8)))))
         (equal? header (decode-xz-stream-header bv)))))))


;; XZ stream footers

(define xz-magic-footer #vu8(#x59 #x5a))

(define $xz-size
  (arbitrary
   (gen (generator-let* ((n (choose-integer 0 (1- (expt 2 32)))))
          (generator-return (* (1+ n) 4))))
   (xform generator-variant)))

(define $xz-stream-footer
  ($record make-xz-stream-footer
    (xz-stream-footer-check-type $nibble)
    (xz-stream-footer-reserved ($tuple $byte $nibble))
    (xz-stream-footer-backward-size $xz-size)
    (xz-stream-footer-crc32 $crc32)))

(define (bytevector-set-xz-magic-footer! bv)
  (let* ((size (min (bytevector-length xz-magic-footer)
                    (bytevector-length bv)))
         (start (- (bytevector-length bv) size)))
    (bytevector-copy! xz-magic-footer 0 bv start size)))

(test-assert "Refuses to decode a small XZ stream footer"
  (true-if-exception
   (let ((bv (make-bytevector 14)))
     (bytevector-set-xz-magic-footer! bv)
     (decode-xz-stream-footer bv))))

(test-assert "Refuses to decode a large XZ stream footer"
  (true-if-exception
   (let ((bv (make-bytevector 10)))
     (bytevector-set-xz-magic-footer! bv)
     (decode-xz-stream-footer bv))))

(test-assert "Refuses to decode XZ stream footer without magic"
  (true-if-exception
   (let ((bv (make-bytevector 12)))
     (decode-xz-stream-footer bv))))

(test-assert "Does not store a trivial XZ stream footer CRC"
  (let ((bv #vu8(36 119 246 129 1 2 3 4 5 6 0 0)))
    (bytevector-set-xz-magic-footer! bv)
    (let ((footer (decode-xz-stream-footer bv)))
      (not (xz-stream-footer-crc32 footer)))))

(configure-quickcheck
 (size (const 12)))

(test-assert "[prop] Reading XZ stream footers is reversible"
  (quickcheck
   (property ((bv $bytevector))
     (bytevector-set-xz-magic-footer! bv)
     (equal? bv (encode-xz-stream-footer (decode-xz-stream-footer bv))))))

(test-assert "[prop] Writing XZ stream footers is reversible"
  (quickcheck
   (property ((footer $xz-stream-footer))
     (let ((bv (encode-xz-stream-footer footer)))
       ;; If we happen to generate a footer with the correct CRC, it
       ;; will become #f when we decode it.
       (test-when (not (and=> (xz-stream-footer-crc32 footer)
                              (lambda (crc32)
                                (= crc32 (bytevector-xz-crc32 bv 6 8)))))
         (equal? footer (decode-xz-stream-footer bv)))))))


;; XZ filter flags

(define $xz-filter-flags
  ($record make-xz-filter-flags
    (xz-filter-flags-id $xz-integer)
    (xz-filter-flags-properties $bytevector)))

(define $xz-filter-flags-bytevector
  (let ((choose-xz-integer-bytevector (arbitrary-gen $xz-integer-bytevector)))
    (arbitrary
     (gen (generator-let* ((id choose-xz-integer-bytevector)
                           (props (sized-generator choose-bytevector)))
            (let ((size (encode-xz-integer (bytevector-length props))))
              (generator-return (bytevector-append id size props)))))
     (xform (arbitrary-xform $bytevector)))))

(test-assert "Refuses to decode small XZ filter flags properties"
  (true-if-exception
   (let ((bv #vu8(0 2 1)))
     (decode-xz-filter-flags bv))))

(test-assert "Refuses to decode large XZ filter flags properties"
  (true-if-exception
   (let ((bv #vu8(0 2 1 2 3)))
     (decode-xz-filter-flags bv))))

(configure-quickcheck
 (size test-size-zero-to-ten))

(test-assert "[prop] Reading XZ filter flags is reversible"
  (quickcheck
   (property ((bv $xz-filter-flags-bytevector))
     (equal? bv (encode-xz-filter-flags (decode-xz-filter-flags bv))))))

(test-assert "[prop] Writing XZ filter flags is reversible"
  (quickcheck
   (property ((filter $xz-filter-flags))
     (equal? filter (decode-xz-filter-flags
                     (encode-xz-filter-flags filter))))))


;; XZ block headers

(define ($one-to-four elem)
  (let* ((base ($list elem)))
    (arbitrary
     (gen (sized-generator
           (lambda (size)
             (choose-list (arbitrary-gen elem) (1+ (modulo size 4))))))
     (xform (arbitrary-xform base)))))

(define $xz-block-header
  ;; We do a little dance here to set the padding correctly.
  (let* ((base ($record make-xz-block-header
                 (xz-block-header-reserved $nibble)
                 (xz-block-header-compressed-size ($maybe $xz-integer))
                 (xz-block-header-uncompressed-size ($maybe $xz-integer))
                 (xz-block-header-filters ($one-to-four $xz-filter-flags))
                 (xz-block-header-padding $nibble)
                 (xz-block-header-crc32 $crc32)))
         (base-gen (arbitrary-gen base)))
    (arbitrary
     (gen (generator-let* ((bh base-gen))
            (let* ((size (- (xz-block-header-size bh)
                            (xz-block-header-padding bh)))
                   (remainder (modulo size 4))
                   (base-padding (if (zero? remainder) 0 (- 4 remainder)))
                   (padding (+ (* 4 (xz-block-header-padding bh))
                               base-padding)))
              (generator-return
               (set-xz-block-header-padding bh padding)))))
     (xform (arbitrary-xform base)))))

(configure-quickcheck
 (size test-size-zero-to-ten))

(test-assert "[prop] Reading XZ block headers is reversible"
  (quickcheck
   (property ((reserved $nibble)
              (c-size ($maybe $xz-integer-bytevector))
              (u-size ($maybe $xz-integer-bytevector))
              (filters ($one-to-four $xz-filter-flags-bytevector))
              (extra-padding $nibble)
              (crc $crc32-bytevector))
     (let* ((base-size (+ 1 1 4
                          (if c-size (bytevector-length c-size) 0)
                          (if u-size (bytevector-length u-size) 0)
                          (reduce + 0 (map bytevector-length filters))
                          (* 4 extra-padding)))
            (remainder (modulo base-size 4))
            (padding (if (zero? remainder) 0 (- 4 remainder)))
            (size (+ base-size padding))
            (encoded-size (1- (quotient size 4)))
            (flags (logior (1- (length filters))
                           (ash reserved 2)
                           (ash (if c-size 1 0) 6)
                           (ash (if u-size 1 0) 7)))
            (filters-bv (apply bytevector-append filters))
            (padding-bv (make-bytevector (+ (* 4 extra-padding) padding) 0))
            (bv (bytevector-append #vu8(0 0)
                                   (or c-size #vu8())
                                   (or u-size #vu8())
                                   filters-bv
                                   padding-bv
                                   crc)))
       (bytevector-u8-set! bv 0 encoded-size)
       (bytevector-u8-set! bv 1 flags)
       (equal? bv (encode-xz-block-header (decode-xz-block-header bv)))))))

(test-assert "[prop] Writing XZ block headers is reversible"
  (quickcheck
   (property ((header $xz-block-header))
     (equal? header (decode-xz-block-header
                     (encode-xz-block-header header))))))


;; XZ index records

(define $xz-index-record
  ($record make-xz-index-record
    (xz-index-record-unpadded-size $xz-integer)
    (xz-index-record-uncompressed-size $xz-integer)))

(define $xz-index-record-bytevector
  (let ((choose-xz-integer-bytevector (arbitrary-gen $xz-integer-bytevector)))
    (arbitrary
     (gen (generator-let* ((up-size choose-xz-integer-bytevector)
                           (uc-size choose-xz-integer-bytevector))
            (generator-return (bytevector-append up-size uc-size))))
     (xform (arbitrary-xform $bytevector)))))

(test-assert "Refuses to decode small XZ index record"
  (true-if-exception
   (let ((bv #vu8(1)))
     (decode-xz-index-record bv))))

(test-assert "Refuses to decode large XZ index record"
  (true-if-exception
   (let ((bv #vu8(1 1 1)))
     (decode-xz-index-record bv))))

(configure-quickcheck
 (size test-size-zero-to-ten))

(test-assert "[prop] Reading XZ index records is reversible"
  (quickcheck
   (property ((bv $xz-index-record-bytevector))
     (equal? bv (encode-xz-index-record (decode-xz-index-record bv))))))

(test-assert "[prop] Writing XZ index records is reversible"
  (quickcheck
   (property ((record $xz-index-record))
     (equal? record (decode-xz-index-record
                     (encode-xz-index-record record))))))


;; XZ indexes

(define $xz-index
  ($record make-xz-index
    (xz-index-records ($list $xz-index-record))
    (xz-index-crc32 $crc32)))

(test-assert "Refuses to decode a small XZ index"
  (true-if-exception
   (let ((bv #vu8(0 2 1 1 0 0 0 0)))
     (decode-xz-index bv))))

(test-assert "Refuses to decode a large XZ index"
  (true-if-exception
   (let ((bv #vu8(0 3 1 1 2 2 3 3 4 4 0 0 0 0 0 0)))
     (decode-xz-index bv))))

(test-assert "Refuses to decode XZ stream index without magic"
  (true-if-exception
   ;; The initial zero is the "magic".
   (let ((bv #vu8(1 1 1 1 0 0 0 0)))
     (decode-xz-index bv))))

(test-assert "Does not store a trivial XZ index CRC"
  (let ((bv #vu8(0 1 1 1 252 180 154 78)))
    (let ((header (decode-xz-index bv)))
      (not (xz-index-crc32 header)))))

(test-assert "Refuses to decode XZ index with nonzero padding"
  (true-if-exception
   (let ((bv #vu8(0 2 1 1 2 2 3 3 0 0 0 0)))
     (decode-xz-index bv))))

(configure-quickcheck
 (size test-size-zero-to-ten))

(test-assert "[prop] Reading XZ indexes is reversible"
  (quickcheck
   (property ((rbvs ($list $xz-index-record-bytevector))
              (crc $crc32-bytevector))
     (let* ((count (encode-xz-integer (length rbvs)))
            (count-size (bytevector-length count))
            (rbvs-size (reduce + 0 (map bytevector-length rbvs)))
            (size (+ 1 count-size rbvs-size))
            (remainder (modulo size 4))
            (padding-size (if (zero? remainder) 0 (- 4 remainder)))
            (padding (make-bytevector padding-size 0))
            (rsbv (apply bytevector-append rbvs))
            (bv (bytevector-append #vu8(0) count rsbv padding crc)))
       (equal? bv (encode-xz-index (decode-xz-index bv)))))))

(test-assert "[prop] Writing XZ indexes is reversible"
  (quickcheck
   (property ((index $xz-index))
     (let* ((bv (encode-xz-index index))
            (end (- (bytevector-length bv) 4)))
       ;; If we happen to generate an index with the correct CRC, it
       ;; will become #f when we decode it.
       (test-when (not (and=> (xz-index-crc32 index)
                              (lambda (crc32)
                                (= crc32 (bytevector-xz-crc32 bv 0 end)))))
         (equal? index (decode-xz-index bv)))))))

(test-end "kinds--xz")