(use-modules (ice-9 match)) (let ((files '(("bootar") ("bootar/scripts") ("bootar/scripts/bzip2.in" . "#!@GUILE@ \\ --no-auto-compile -L @MODDIR@ -C @GODIR@ -e main -s !# ;;; Bootar ;;; Copyright 2020 Timothy Sample ;;; ;;; This file is part of Bootar. ;;; ;;; Bootar 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. ;;; ;;; Bootar 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 Bootar. If not, see ;;; . (use-modules (compression bzip2) (ice-9 binary-ports) (ice-9 getopt-long) (ice-9 match) (rnrs bytevectors)) (define *option-spec* '((decompress (single-char #\\d)) (stdout (single-char #\\c)))) (define (bunzip in out) (let* ((size (* 64 1024 1024)) (bv (make-bytevector size)) (in* (make-bzip2-input-port in \"bzip2\" #t))) (let lp ((n (get-bytevector-n! in* bv 0 size))) (unless (eof-object? n) (put-bytevector out bv 0 n) (lp (get-bytevector-n! in* bv 0 size)))))) (define (main args) (let* ((options (getopt-long args *option-spec*)) (decompress (option-ref options 'decompress #f)) (stdout (option-ref options 'stdout #f)) (filenames (match (option-ref options '() '()) (() '(\"-\")) (x x)))) (unless decompress (format (current-error-port) \"bzip2: only decompression is supported~%\") (exit #f)) (unless (or stdout (equal? filenames '(\"-\"))) (format (current-error-port) \"bzip2: only writing to stdout is supported~%\") (exit #f)) (for-each (match-lambda (\"-\" (bunzip (current-input-port) (current-output-port))) (filename (call-with-input-file filename (lambda (port) (bunzip port (current-output-port)))))) filenames) (exit #t))) ;;; Local Variables: ;;; mode: scheme ;;; End: ") ("bootar/scripts/gzip.in" . "#!@GUILE@ \\ --no-auto-compile -L @MODDIR@ -C @GODIR@ -e main -s !# ;;; Bootar ;;; Copyright 2020 Timothy Sample ;;; ;;; This file is part of Bootar. ;;; ;;; Bootar 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. ;;; ;;; Bootar 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 Bootar. If not, see ;;; . (use-modules (compression gzip) (ice-9 binary-ports) (ice-9 getopt-long) (ice-9 match) (rnrs bytevectors)) (define *option-spec* '((decompress (single-char #\\d)) (stdout (single-char #\\c)))) (define (gunzip in out) (let* ((size (* 64 1024 1024)) (bv (make-bytevector size)) (in* (make-gzip-input-port in \"gzip\" #t))) (let lp ((n (get-bytevector-n! in* bv 0 size))) (unless (eof-object? n) (put-bytevector out bv 0 n) (lp (get-bytevector-n! in* bv 0 size)))))) (define (main args) (let* ((options (getopt-long args *option-spec*)) (decompress (option-ref options 'decompress #f)) (stdout (option-ref options 'stdout #f)) (filenames (match (option-ref options '() '()) (() '(\"-\")) (x x)))) (unless decompress (format (current-error-port) \"gzip: only decompression is supported~%\") (exit #f)) (unless (or stdout (equal? filenames '(\"-\"))) (format (current-error-port) \"gzip: only writing to stdout is supported~%\") (exit #f)) (for-each (match-lambda (\"-\" (gunzip (current-input-port) (current-output-port))) (filename (call-with-input-file filename (lambda (port) (gunzip port (current-output-port)))))) filenames) (exit #t))) ;;; Local Variables: ;;; mode: scheme ;;; End: ") ("bootar/scripts/tar.in" . "#!@GUILE@ \\ --no-auto-compile -L @MODDIR@ -C @GODIR@ -e main -s !# ;;; Bootar ;;; Copyright 2020 Timothy Sample ;;; ;;; This file is part of Bootar. ;;; ;;; Bootar 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. ;;; ;;; Bootar 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 Bootar. If not, see ;;; . (use-modules (compression bzip2) (compression gzip) (compression tar) (compression xz) (ice-9 match)) (define (ensure-directory filename) (let* ((directory (dirname filename)) (st (stat directory #f))) (if st (unless (eq? (stat:type st) 'directory) (error \"file exists\" directory)) (begin (ensure-directory directory) (format #t \"~a~%\" directory) (mkdir directory))))) (define (extract-tar-port port) (let loop ((header (get-header-record port))) (unless (eof-object? header) (case (header-typeflag header) ((regular directory symlink) (let* ((name (header-name header)) (mode (header-mode header))) ;; It seems that some tarballs do not put the directories ;; first (namely 'mes-0.21-54-g85cadbb2c'). (ensure-directory name) (format #t \"~a~%\" name) (force-output) (case (header-typeflag header) ((regular) (call-with-output-file name (lambda (out) (extract-to-port port header out))) (chmod name mode)) ((directory) (mkdir (header-name header)) (skip-file port header) (chmod name mode)) ((symlink) (symlink (header-linkname header) name) ;; XXX: Create the symlink with umask to preserve the ;; permissions? (skip-file port header))))) (else => (lambda (x) (error \"cannot handle typeflag\" x)))) (loop (get-header-record port))))) (define (extract-tar-file filename) (call-with-input-file filename (lambda (port) (cond ((is-gzip-file? port) (let* ((id (string-append \"gzip \" filename)) (gzip-port (make-gzip-input-port port id #t))) (extract-tar-port gzip-port))) ((is-xz-file? port) (let* ((id (string-append \"xz \" filename)) (xz-port (make-xz-input-port port id #t))) (extract-tar-port xz-port))) ((is-bzip2-file? port) (let* ((id (string-append \"bzip2 \" filename)) (bzip2-port (make-bzip2-input-port port id #t))) (extract-tar-port bzip2-port))) (else (extract-tar-port port)))))) (define (main args) (match args ((_ \"xvf\" filename) (extract-tar-file filename) (exit #t)) (_ (format (current-error-port) \"tar: invalid arguments; try 'xvf'~%\") (exit #f)))) ;;; Local Variables: ;;; mode: scheme ;;; End: ") ("bootar/scripts/xz.in" . "#!@GUILE@ \\ --no-auto-compile -L @MODDIR@ -C @GODIR@ -e main -s !# ;;; Bootar ;;; Copyright 2020 Timothy Sample ;;; ;;; This file is part of Bootar. ;;; ;;; Bootar 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. ;;; ;;; Bootar 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 Bootar. If not, see ;;; . (use-modules (compression xz) (ice-9 binary-ports) (ice-9 getopt-long) (ice-9 match) (rnrs bytevectors)) (define *option-spec* '((decompress (single-char #\\d)) (stdout (single-char #\\c)) (threads (single-char #\\T) (value #t)))) (define (xzdec in out) (let* ((size (* 64 1024 1024)) (bv (make-bytevector size)) (in* (make-xz-input-port in \"xz\" #t))) (let lp ((n (get-bytevector-n! in* bv 0 size))) (force-output) (unless (eof-object? n) (put-bytevector out bv 0 n) (lp (get-bytevector-n! in* bv 0 size)))))) (define (main args) (let* ((options (getopt-long args *option-spec*)) (decompress (option-ref options 'decompress #f)) (stdout (option-ref options 'stdout #f)) (filenames (match (option-ref options '() '()) (() '(\"-\")) (x x)))) (unless decompress (format (current-error-port) \"xz: only decompression is supported~%\") (exit #f)) (unless (or stdout (equal? filenames '(\"-\"))) (format (current-error-port) \"xz: only writing to stdout is supported~%\") (exit #f)) (for-each (match-lambda (\"-\" (format (current-error-port) \"xz: cannot decompress from stdin~%\") (exit #f)) (filename (call-with-input-file filename (lambda (port) (xzdec port (current-output-port)))))) filenames) (exit #t))) ;;; Local Variables: ;;; mode: scheme ;;; End: ") ("bootar/hashing") ("bootar/hashing/private") ("bootar/hashing/private/common.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2017, 2018 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs (library (hashing private common) (export iota decode-coefficients symcat) (import (rnrs)) (define (iota n) (unless (>= n 0) (error 'iota \"Argument must be non-negative\" n)) (let lp ((n n) (acc '())) (if (= n 0) acc (lp (- n 1) (cons (- n 1) acc))))) (define (decode-coefficients coeffs) (do ((i coeffs (cdr i)) (p 0 (bitwise-ior p (bitwise-arithmetic-shift-left 1 (car i))))) ((null? i) p))) (define (symcat name suffix) (datum->syntax name (string->symbol (string-append (symbol->string (syntax->datum name)) suffix))))) ") ("bootar/hashing/private/compat.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2016, 2018 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs (library (hashing private compat) (export bitwise-rotate-bit-field bitwise-reverse-bit-field) (import (only (rnrs) bitwise-rotate-bit-field bitwise-reverse-bit-field))) ") ("bootar/hashing/fixnums.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2018, 2020 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs ;;; Easy definition of special-cased fixnum procedures. (library (hashing fixnums) (export define-fixnum-procedures) (import (rnrs (6))) (define-syntax define-fx (lambda (x) (syntax-case x () ((k prefix bit-width op-name fxname bitwise-name) (with-syntax ((name (datum->syntax #'prefix (string->symbol (string-append (symbol->string (syntax->datum #'prefix)) (symbol->string (syntax->datum #'op-name))))))) #'(define name (if (> (fixnum-width) bit-width) fxname bitwise-name))))))) (define-syntax define-fixnum-procedures (lambda (x) (syntax-case x () ((_ prefix bit-width) #'(begin (define-fx prefix bit-width and fxand bitwise-and) (define-fx prefix bit-width xor fxxor bitwise-xor) (define-fx prefix bit-width ior fxior bitwise-ior) (define-fx prefix bit-width not fxnot bitwise-not) (define-fx prefix bit-width + fx+ +) (define-fx prefix bit-width - fx- -) (define-fx prefix bit-width * fx* *) (define-fx prefix bit-width =? fx=? =) (define-fx prefix bit-width bit-set? fxbit-set? bitwise-bit-set?) (define-fx prefix bit-width arithmetic-shift-right fxarithmetic-shift-right bitwise-arithmetic-shift-right) (define-fx prefix bit-width arithmetic-shift-left fxarithmetic-shift-left bitwise-arithmetic-shift-left) (define-fx prefix bit-width zero? fxzero? zero?) (define-fx prefix bit-width bit-field fxbit-field bitwise-bit-field) (define-fx prefix bit-width rotate-bit-field fxrotate-bit-field bitwise-rotate-bit-field) (define-fx prefix bit-width length fxlength bitwise-length))))))) ") ("bootar/hashing/crc.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2009, 2011, 2012, 2017, 2018 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; Syntax for defining procedures that calculate Cyclic Redundancy Codes. ;; Ross N. Williams, \"A painless guide to CRC error detection ;; algorithms\". http://www.ross.net/crc/crcpaper.html ;;; Simple usage with pre-defined CRCs ;; If you want to use one of the pre-defined CRCs ;; (define-crc crc-32) ;; calculates the CRC table at expand-time and defines the ;; procedures below ;; (crc-32 bytevector) ;; returns the final CRC of the entire bytevector ;; (crc-32-init) ;; returns an initial CRC state ;; (crc-32-update state bv) ;; (crc-32-update state bv start) ;; (crc-32-update state bv start end) ;; returns a new state which includes the CRC on the given bytes ;; (crc-32-finish state) ;; returns the final CRC ;; (crc-32-width) ;; returns the bit-width of the CRC, e.g. 32 for CRC-32 ;; (crc-32-self-test) ;; returns 'sucess, 'failure, or 'no-self-test ;;; Advanced usage ;; Quick and possibly confusing guide to using define-crc with new ;; CRCs, for those who are too busy to read the above paper: ;; Syntax: (define-crc name width polynomial init ref-in ref-out ;; xor-out check) ;; Syntax: ;; (define-crc ;; (width ) ;; (polynomial ) ;; (init ) ;; (ref-in ) ;; (ref-out ) ;; (xor-out ) ;; (check )) ;; The width is the bitwise length of the polynomial. You might be ;; lead to believe that it should sometimes be 33, but if so you've ;; been counting the highest bit, which doesn't count. ;; The polynomial for CRC-16 is given sometimes given as x^16 + x^15 + ;; x^2 + 1. This translates to #b1000000000000101 (#x8005). Note that ;; x^16 is absent. CRCs use polynomial division with modulo two ;; arithmetic (better known as XOR). Don't use the reversed polynomial ;; if you have one of those, instead set ref-in and ref-out properly. ;; After a CRC has been calculated it is sometimes XOR'd with a final ;; value, this is xor-out. ;; check is either the CRC of the ASCII string \"123456789\", or #f. ;; Syntax: (define-crc name (coefficients ...) init ref-in ref-out ;; xor-out check) ;; Syntax: ;; (define-crc ;; (polynomial (coefficients ...)) ;; (init ) ;; (ref-in ) ;; (ref-out ) ;; (xor-out ) ;; (check )) ;; This is the slightly easier interface where you can simply specify ;; the powers of the coefficients. CRC-16 in this syntax becomes: ;; (define-crc crc-16 (16 15 2 0) #x0000 #t #t #x0000 #xBB3D) ;; Another example: the polynomial x^8 + x^2 + x + 1 in this syntax ;; becomes: (8 2 1 0). Note how the last \"1\" is 0. ;;; Bit-oriented CRCs ;; Use define-bitwise-crc when working with bytevectors where each ;; byte represents a bit, e.g. #vu8(0 1 1 1). (library (hashing crc) (export define-crc define-bit-oriented-crc width polynomial init ref-in ref-out xor-out check) (import (except (rnrs (6)) bitwise-rotate-bit-field bitwise-reverse-bit-field) (hashing fixnums) (for (hashing private common) expand) (hashing private compat)) ;; This makes the auxiliary keywords work in the Chez repl. (define-syntax define-auxiliary-keyword* (lambda (x) (syntax-case x () ((_ keyword) #'(define-syntax keyword (lambda (x) (syntax-violation #f \"incorrect usage of auxiliary keyword\" x)))) ((_ keyword0 keyword* ...) #'(begin (define-auxiliary-keyword* keyword0) (define-auxiliary-keyword* keyword* ...)))))) (define-auxiliary-keyword* width polynomial init ref-in ref-out xor-out check) (define (string->bits str reverse-bytes) ;; Horrible code that's only used for the bit-oriented test vectors. (u8-list->bytevector (apply append (map (lambda (x) (let* ((s (number->string x 2)) (s (string-append (make-string (- 8 (string-length s)) #\\0) s)) (l (map (lambda (x) (if (char=? x #\\1) 1 0)) (string->list s)))) (if reverse-bytes (reverse l) l))) (bytevector->u8-list (string->utf8 str)))))) ;; Bit-oriented. (define-syntax define-bit-oriented-crc (lambda (x) (syntax-case x (width polynomial init ref-in ref-out xor-out check) [(_ name (polynomial (width^ coeff* ...)) (init init^) (ref-in ref-in^) (ref-out ref-out^) (xor-out xor-out^) (check check^)) #'(define-bit-oriented-crc name (width^ coeff* ...) init^ ref-in^ ref-out^ xor-out^ check^)] [(_ name (width width^) (polynomial poly^) (init init^) (ref-in ref-in^) (ref-out ref-out^) (xor-out xor-out^) (check check^)) #'(define-bit-oriented-crc name width^ poly^ init^ ref-in^ ref-out^ xor-out^ check^)] ((_ name (width-value coeff* ...) . rest) (with-syntax ((polynomial (decode-coefficients (syntax->datum #'(coeff* ...))))) #'(define-bit-oriented-crc name width-value polynomial . rest))) [(_ name width^ poly^ init^ ref-in^ ref-out^ xor-out^ check^) (with-syntax ((crc-init (symcat #'name \"-init\")) (crc-finish (symcat #'name \"-finish\")) (crc-update (symcat #'name \"-update\")) (crc-self-test (symcat #'name \"-self-test\")) (crc-width (symcat #'name \"-width\"))) (unless (and (syntax->datum #'ref-in^) (syntax->datum #'ref-out^)) ;; TODO: implement everything else (syntax-violation x \"ref-in=#f is unimplemented\" #'ref-in^)) #`(begin (define (name bv) (crc-finish (crc-update (crc-init) bv))) (define (crc-init) init^) (define (crc-finish r) (bitwise-xor r xor-out^)) (define (crc-self-test) (if check^ (let ((check-value (if ref-out^ (bitwise-reverse-bit-field check^ 0 width^)))) (if (= (name (string->bits \"123456789\" ref-in^)) check-value) 'success 'failure)) 'no-self-test)) (define (crc-width) width^) (define crc-update (case-lambda ((r* bv) (crc-update r* bv 0 (bytevector-length bv))) ((r* bv start) (crc-update r* bv start (bytevector-length bv))) ((r* bv start end) (define-fixnum-procedures fw width^) (define mask (- (bitwise-arithmetic-shift-left 1 (- width^ 1)) 1)) (do ((i start (fx+ i 1)) (r r* (let ((inv (fwxor (bytevector-u8-ref bv i) (fwarithmetic-shift-right r (- width^ 1))))) ;; XX: slowly works with one bit at a time. (fwior (fwarithmetic-shift-left (fwxor (fwand r mask) (fwand (fwarithmetic-shift-right poly^ 1) (fw- inv))) 1) inv)))) ((fx=? i end) r)))))))]))) ;; Byte-oriented. (define-syntax define-crc (lambda (x) (define (calc-table index width ref-in poly) (if ref-in (bitwise-reverse-bit-field (calc-table (bitwise-reverse-bit-field index 0 8) width #f poly) 0 width) (do ((bit 0 (+ bit 1)) (r (bitwise-arithmetic-shift-left index (- width 8)) (if (bitwise-bit-set? r (- width 1)) (bitwise-xor (bitwise-arithmetic-shift-left r 1) poly) (bitwise-arithmetic-shift-left r 1)))) ((= bit 8) (bitwise-bit-field r 0 width))))) (syntax-case x (width polynomial init ref-in ref-out xor-out check) [(_ name) ;; Contributions are welcome. There should also be more ;; references here. A lot of work went into finding these ;; polynomials, and they are reduced to one-liners. (case (syntax->datum #'name) ;; Used for .ZIP, AUTODIN II, Ethernet, FDDI, PNG, MPEG-2 ;; and various other things. ((crc-32) #'(define-crc name 32 #x04C11DB7 #xFFFFFFFF #t #t #xFFFFFFFF #xCBF43926)) ((crc-16) #'(define-crc name 16 #x8005 #x0000 #t #t #x0000 #xBB3D)) ((crc-16/ccitt) ;; Used by XMODEM, PPP and much more #'(define-crc name 16 #x1021 #xffff #f #f 0 #x29B1)) ((crc-32c) ;; CRC-32C specified in e.g. RFC4960 or RFC3385. Used by SCTP ;; and iSCSI. Finds more errors than CRC-32. #'(define-crc name 32 #x1EDC6F41 #xFFFFFFFF #t #t #xFFFFFFFF #xE3069283)) ;; OpenPGP, see RFC2440. ((crc-24) #'(define-crc name (24 23 18 17 14 11 10 7 6 5 4 3 1 0) #xB704CE #f #f 0 #x21CF02)) ((crc-64) #'(define-crc name (64 4 3 1 0) 0 #t #t 0 #x46A5A9388A5BEFFE)) ((crc-64/ecma-182) ;; Used by XZ #'(define-crc name (64 62 57 55 54 53 52 47 46 45 40 39 38 37 35 33 32 31 29 27 24 23 22 21 19 17 13 12 10 9 7 4 1 0) #xFFFFFFFFFFFFFFFF #t #t #xFFFFFFFFFFFFFFFF #x995DC9BBDF1939FA)) (else (syntax-violation #f \"this CRC is not pre-defined\" #'name)))] [(_ name (polynomial (width^ coeff* ...)) (init init^) (ref-in ref-in^) (ref-out ref-out^) (xor-out xor-out^) (check check^)) #'(define-crc name (width^ coeff* ...) init^ ref-in^ ref-out^ xor-out^ check^)] [(_ name (width width^) (polynomial poly^) (init init^) (ref-in ref-in^) (ref-out ref-out^) (xor-out xor-out^) (check check^)) #'(define-crc name width^ poly^ init^ ref-in^ ref-out^ xor-out^ check^)] [(_ name (width^ coeffs ...) . rest) (with-syntax ((polynomial (decode-coefficients (syntax->datum #'(coeffs ...))))) #'(define-crc name width^ polynomial . rest))] [(_ name width^ polynomial^ init^ ref-in^ ref-out^ xor-out^ check^) (and (identifier? #'name) (>= (syntax->datum #'width^) 8) (zero? (mod (syntax->datum #'width^) 8))) ;; TODO: test different widths. (let* ((width* (syntax->datum #'width^)) (polynomial* (syntax->datum #'polynomial^)) (init* (syntax->datum #'init^)) (ref-in* (syntax->datum #'ref-in^)) (ref-out* (syntax->datum #'ref-out^))) (unless (boolean=? ref-in* ref-out*) ;; TODO: implement the other ref-in ref-out combinations? (syntax-violation x \"Mixed in/out reflection is unimplemented\" ref-in* ref-out*)) (with-syntax ((init (if ref-in* (bitwise-reverse-bit-field init* 0 width*) init*)) (table (list->vector (map (lambda (i) (calc-table i width* ref-in* polynomial*)) (iota 256)))) (crc-init (symcat #'name \"-init\")) (crc-finish (symcat #'name \"-finish\")) (crc-update (symcat #'name \"-update\")) (crc-self-test (symcat #'name \"-self-test\")) (crc-width (symcat #'name \"-width\"))) #`(begin (define (name bv) (crc-finish (crc-update (crc-init) bv))) (define (crc-init) init) (define (crc-finish r) (bitwise-xor r xor-out^)) (define (crc-self-test) (if check^ (if (= (name (string->utf8 \"123456789\")) check^) 'success 'failure) 'no-self-test)) (define (crc-width) width^) (define crc-update (case-lambda ((r* bv) (crc-update r* bv 0 (bytevector-length bv))) ((r* bv start) (crc-update r* bv start (bytevector-length bv))) ((r* bv start end) (define-fixnum-procedures fw width^) (define mask (- (bitwise-arithmetic-shift-left 1 (- width^ 8)) 1)) (define t 'table) (do ((i start (fx+ i 1)) (r r* (if (and ref-in^ ref-out^) (fwxor (fwarithmetic-shift-right r 8) (vector-ref t (fwxor (fwand #xff r) (bytevector-u8-ref bv i)))) (fwxor (fwarithmetic-shift-left (fwand mask r) 8) (vector-ref t (fwxor (bytevector-u8-ref bv i) (fwand (fwarithmetic-shift-right r (- width^ 8)) #xff))))))) ((fx=? i end) r))))))))])))) ") ("bootar/hashing/hmac.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2009, 2012, 2017, 2018 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs ;; RFC 2104, FIPS-198-1. (library (hashing hmac) (export make-hmac) (import (rnrs)) ;; Returns a procedure that calculates the HMAC given a secret and ;; data (both of which are bytevectors). (define (make-hmac block-length hash ->bytevector make-hash update! finish! clear!) (lambda (secret . data) (let lp ((secret secret)) (if (> (bytevector-length secret) block-length) (lp (->bytevector (hash secret))) (let ((k-ipad (make-bytevector block-length 0)) (k-opad (make-bytevector block-length 0))) (bytevector-copy! secret 0 k-ipad 0 (bytevector-length secret)) (bytevector-copy! secret 0 k-opad 0 (bytevector-length secret)) (do ((i 0 (fx+ i 1))) ((fx=? i block-length)) (bytevector-u8-set! k-ipad i (fxxor #x36 (bytevector-u8-ref k-ipad i))) (bytevector-u8-set! k-opad i (fxxor #x5c (bytevector-u8-ref k-opad i)))) (let ((state (make-hash))) (update! state k-ipad) (for-each (lambda (d) (update! state d)) data) (finish! state) (let ((digest (->bytevector state))) (clear! state) (update! state k-opad) (update! state digest) (finish! state) state)))))))) ") ("bootar/hashing/sha-2.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2009, 2010, 2012, 2017, 2018, 2020 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs ;; Byte-oriented SHA-224/256 and SHA-384/512 from FIPS 180-3 ;; RFC3874 SHA-224 ;; TODO: give an error if more than 2^64 / 2^128 bits are processed? (library (hashing sha-2) (export make-sha-224 sha-224-update! sha-224-finish! sha-224-clear! sha-224 sha-224-copy sha-224-finish sha-224-length sha-224-copy-hash! sha-224-128-copy-hash! sha-224->bytevector sha-224->string sha-224-hash=? sha-224-128-hash=? hmac-sha-224 make-sha-256 sha-256-update! sha-256-finish! sha-256-clear! sha-256 sha-256-copy sha-256-finish sha-256-length sha-256-copy-hash! sha-256-128-copy-hash! sha-256->bytevector sha-256->string sha-256-hash=? sha-256-128-hash=? hmac-sha-256 make-sha-384 sha-384-update! sha-384-finish! sha-384-clear! sha-384 sha-384-copy sha-384-finish sha-384-length sha-384-copy-hash! sha-384-128-copy-hash! sha-384->bytevector sha-384->string sha-384-hash=? sha-384-128-hash=? hmac-sha-384 make-sha-512 sha-512-update! sha-512-finish! sha-512-clear! sha-512 sha-512-copy sha-512-finish sha-512-length sha-512-copy-hash! sha-512-128-copy-hash! sha-512->bytevector sha-512->string sha-512-hash=? sha-512-128-hash=? hmac-sha-512) (import (rnrs arithmetic bitwise) (rnrs base) (rnrs bytevectors) (rnrs control) (rnrs mutable-strings) (rnrs records syntactic) (rnrs syntax-case) (hashing fixnums) (hashing hmac)) (define-fixnum-procedures f32 33) (define-fixnum-procedures fx 20) (define (sha-224-length) 224/8) (define (sha-256-length) 256/8) (define (sha-384-length) 384/8) (define (sha-512-length) 512/8) (define (vector-copy x) (vector-map (lambda (i) i) x)) (define-record-type sha-state (nongenerative sha-shate-v1-e2d81f8b-05e3-4e74-b53e-4dd242d3f65f) (sealed #t) (fields (immutable H) ;Hash (immutable init) ;initial hash (immutable W) ;temporary data (immutable m) ;unprocessed data (mutable pending) ;length of unprocessed data (mutable processed))) ;length of processed data (define (make-sha-2 initial-hash) (let ((W (make-vector 80 #f)) (m (make-bytevector (* 4 32)))) (make-sha-state (list->vector initial-hash) initial-hash W m 0 0))) (define (make-sha-224) (make-sha-2 initial-hash224)) (define (make-sha-256) (make-sha-2 initial-hash256)) (define (make-sha-384) (make-sha-2 initial-hash384)) (define (make-sha-512) (make-sha-2 initial-hash512)) (define (sha-2-copy state) (let ((H (vector-copy (sha-state-H state))) (W (make-vector 80 #f)) (m (bytevector-copy (sha-state-m state)))) (make-sha-state H (sha-state-init state) W m (sha-state-pending state) (sha-state-processed state)))) (define (sha-224-copy x) (sha-2-copy x)) (define (sha-256-copy x) (sha-2-copy x)) (define (sha-384-copy x) (sha-2-copy x)) (define (sha-512-copy x) (sha-2-copy x)) (define (sha-2-clear! state) (do ((init (sha-state-init state) (cdr init)) (i 0 (+ i 1))) ((null? init)) (vector-set! (sha-state-H state) i (car init))) (vector-fill! (sha-state-W state) #f) (bytevector-fill! (sha-state-m state) 0) (sha-state-pending-set! state 0) (sha-state-processed-set! state 0)) (define (sha-224-clear! state) (sha-2-clear! state)) (define (sha-256-clear! state) (sha-2-clear! state)) (define (sha-384-clear! state) (sha-2-clear! state)) (define (sha-512-clear! state) (sha-2-clear! state)) (define initial-hash224 '(#xc1059ed8 #x367cd507 #x3070dd17 #xf70e5939 #xffc00b31 #x68581511 #x64f98fa7 #xbefa4fa4)) (define initial-hash256 '(#x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19)) (define initial-hash384 '(#xcbbb9d5dc1059ed8 #x629a292a367cd507 #x9159015a3070dd17 #x152fecd8f70e5939 #x67332667ffc00b31 #x8eb44a8768581511 #xdb0c2e0d64f98fa7 #x47b5481dbefa4fa4)) (define initial-hash512 '(#x6a09e667f3bcc908 #xbb67ae8584caa73b #x3c6ef372fe94f82b #xa54ff53a5f1d36f1 #x510e527fade682d1 #x9b05688c2b3e6c1f #x1f83d9abfb41bd6b #x5be0cd19137e2179)) (define k-256 '#(#x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5 #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5 #xd807aa98 #x12835b01 #x243185be #x550c7dc3 #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174 #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7 #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967 #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13 #x650a7354 #x766a0abb #x81c2c92e #x92722c85 #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3 #xd192e819 #xd6990624 #xf40e3585 #x106aa070 #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5 #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3 #x748f82ee #x78a5636f #x84c87814 #x8cc70208 #x90befffa #xa4506ceb #xbef9a3f7 #xc67178f2)) (define k-512 '#(#x428a2f98d728ae22 #x7137449123ef65cd #xb5c0fbcfec4d3b2f #xe9b5dba58189dbbc #x3956c25bf348b538 #x59f111f1b605d019 #x923f82a4af194f9b #xab1c5ed5da6d8118 #xd807aa98a3030242 #x12835b0145706fbe #x243185be4ee4b28c #x550c7dc3d5ffb4e2 #x72be5d74f27b896f #x80deb1fe3b1696b1 #x9bdc06a725c71235 #xc19bf174cf692694 #xe49b69c19ef14ad2 #xefbe4786384f25e3 #x0fc19dc68b8cd5b5 #x240ca1cc77ac9c65 #x2de92c6f592b0275 #x4a7484aa6ea6e483 #x5cb0a9dcbd41fbd4 #x76f988da831153b5 #x983e5152ee66dfab #xa831c66d2db43210 #xb00327c898fb213f #xbf597fc7beef0ee4 #xc6e00bf33da88fc2 #xd5a79147930aa725 #x06ca6351e003826f #x142929670a0e6e70 #x27b70a8546d22ffc #x2e1b21385c26c926 #x4d2c6dfc5ac42aed #x53380d139d95b3df #x650a73548baf63de #x766a0abb3c77b2a8 #x81c2c92e47edaee6 #x92722c851482353b #xa2bfe8a14cf10364 #xa81a664bbc423001 #xc24b8b70d0f89791 #xc76c51a30654be30 #xd192e819d6ef5218 #xd69906245565a910 #xf40e35855771202a #x106aa07032bbd1b8 #x19a4c116b8d2d0c8 #x1e376c085141ab53 #x2748774cdf8eeb99 #x34b0bcb5e19b48a8 #x391c0cb3c5c95a63 #x4ed8aa4ae3418acb #x5b9cca4f7763e373 #x682e6ff3d6b2b8a3 #x748f82ee5defb2fc #x78a5636f43172f60 #x84c87814a1f0ab72 #x8cc702081a6439ec #x90befffa23631e28 #xa4506cebde82bde9 #xbef9a3f7b2c67915 #xc67178f2e372532b #xca273eceea26619c #xd186b8c721c0c207 #xeada7dd6cde0eb1e #xf57d4f7fee6ed178 #x06f067aa72176fba #x0a637dc5a2c898a6 #x113f9804bef90dae #x1b710b35131c471b #x28db77f523047d84 #x32caab7b40c72493 #x3c9ebe0a15c9bebc #x431d67c49c100d4c #x4cc5d4becb3e42b6 #x597f299cfc657e2a #x5fcb6fab3ad6faec #x6c44198c4a475817)) ;; This function transforms a whole 512 bit block. (define (sha-256-transform! H* W m offset) (define (ror32 n count) (f32ior (f32arithmetic-shift-left (f32bit-field n 0 count) (f32- 32 count)) (f32arithmetic-shift-right n count))) (define (Ch x y z) (f32xor (f32and x y) (f32and (f32not x) z))) (define (Maj x y z) (f32xor (f32and x y) (f32and x z) (f32and y z))) (define (Sigma0 x) (f32xor (ror32 x 2) (ror32 x 13) (ror32 x 22))) (define (Sigma1 x) (f32xor (ror32 x 6) (ror32 x 11) (ror32 x 25))) (define (sigma0 x) (f32xor (ror32 x 7) (ror32 x 18) (f32arithmetic-shift-right x 3))) (define (sigma1 x) (f32xor (ror32 x 17) (ror32 x 19) (f32arithmetic-shift-right x 10))) ;; Copy the message block (do ((t 0 (f32+ t 1))) ((eqv? t 16)) (vector-set! W t (bytevector-u32-ref m (f32+ (f32* t 4) offset) (endianness big)))) ;; Initialize W[16..63] (do ((t 16 (f32+ t 1))) ((eqv? t 64)) (vector-set! W t (f32and (f32+ (f32+ (sigma1 (vector-ref W (f32- t 2))) (vector-ref W (f32- t 7))) (f32+ (sigma0 (vector-ref W (f32- t 15))) (vector-ref W (f32- t 16)))) #xffffffff))) ;; Do the hokey pokey (let lp ((A (vector-ref H* 0)) (B (vector-ref H* 1)) (C (vector-ref H* 2)) (D (vector-ref H* 3)) (E (vector-ref H* 4)) (F (vector-ref H* 5)) (G (vector-ref H* 6)) (H (vector-ref H* 7)) (t 0)) (cond ((eqv? t 64) (vector-set! H* 0 (f32and #xffffffff (+ A (vector-ref H* 0)))) (vector-set! H* 1 (f32and #xffffffff (+ B (vector-ref H* 1)))) (vector-set! H* 2 (f32and #xffffffff (+ C (vector-ref H* 2)))) (vector-set! H* 3 (f32and #xffffffff (+ D (vector-ref H* 3)))) (vector-set! H* 4 (f32and #xffffffff (+ E (vector-ref H* 4)))) (vector-set! H* 5 (f32and #xffffffff (+ F (vector-ref H* 5)))) (vector-set! H* 6 (f32and #xffffffff (+ G (vector-ref H* 6)))) (vector-set! H* 7 (f32and #xffffffff (+ H (vector-ref H* 7))))) (else (let ((T1 (f32+ (f32+ H (f32+ (Sigma1 E) (Ch E F G))) (f32+ (vector-ref k-256 t) (vector-ref W t)))) (T2 (f32+ (Sigma0 A) (Maj A B C)))) (lp (f32and #xffffffff (f32+ T1 T2)) A B C (f32and #xffffffff (f32+ D T1)) E F G (f32+ t 1))))))) ;; This function transforms a whole 1024 bit block. (define (sha-512-transform! H* W m offset) (define (ror64 n count) (bitwise-ior (bitwise-arithmetic-shift-left (bitwise-bit-field n 0 count) (fx- 64 count)) (bitwise-arithmetic-shift-right n count))) (define (Ch x y z) (bitwise-xor (bitwise-and x y) (bitwise-and (bitwise-not x) z))) (define (Maj x y z) (bitwise-xor (bitwise-and x y) (bitwise-and x z) (bitwise-and y z))) (define (Sigma0 x) (bitwise-xor (ror64 x 28) (ror64 x 34) (ror64 x 39))) (define (Sigma1 x) (bitwise-xor (ror64 x 14) (ror64 x 18) (ror64 x 41))) (define (sigma0 x) (bitwise-xor (ror64 x 1) (ror64 x 8) (bitwise-arithmetic-shift-right x 7))) (define (sigma1 x) (bitwise-xor (ror64 x 19) (ror64 x 61) (bitwise-arithmetic-shift-right x 6))) ;; Copy the message block (do ((t 0 (fx+ t 1))) ((eqv? t 16)) (vector-set! W t (bytevector-u64-ref m (fx+ (fx* t 8) offset) (endianness big)))) ;; Initialize W[16..63] (do ((t 16 (fx+ t 1))) ((eqv? t 80)) (vector-set! W t (bitwise-and (+ (+ (sigma1 (vector-ref W (fx- t 2))) (vector-ref W (fx- t 7))) (+ (sigma0 (vector-ref W (fx- t 15))) (vector-ref W (fx- t 16)))) #xffffffffffffffff))) ;; Do the hokey pokey (let lp ((A (vector-ref H* 0)) (B (vector-ref H* 1)) (C (vector-ref H* 2)) (D (vector-ref H* 3)) (E (vector-ref H* 4)) (F (vector-ref H* 5)) (G (vector-ref H* 6)) (H (vector-ref H* 7)) (t 0)) (cond ((eqv? t 80) (vector-set! H* 0 (bitwise-and #xffffffffffffffff (+ A (vector-ref H* 0)))) (vector-set! H* 1 (bitwise-and #xffffffffffffffff (+ B (vector-ref H* 1)))) (vector-set! H* 2 (bitwise-and #xffffffffffffffff (+ C (vector-ref H* 2)))) (vector-set! H* 3 (bitwise-and #xffffffffffffffff (+ D (vector-ref H* 3)))) (vector-set! H* 4 (bitwise-and #xffffffffffffffff (+ E (vector-ref H* 4)))) (vector-set! H* 5 (bitwise-and #xffffffffffffffff (+ F (vector-ref H* 5)))) (vector-set! H* 6 (bitwise-and #xffffffffffffffff (+ G (vector-ref H* 6)))) (vector-set! H* 7 (bitwise-and #xffffffffffffffff (+ H (vector-ref H* 7))))) (else (let ((T1 (+ (+ H (+ (Sigma1 E) (Ch E F G))) (+ (vector-ref k-512 t) (vector-ref W t)))) (T2 (+ (Sigma0 A) (Maj A B C)))) (lp (bitwise-and #xffffffffffffffff (+ T1 T2)) A B C (bitwise-and #xffffffffffffffff (+ D T1)) E F G (fx+ t 1))))))) (define (sha-224-update! . x) (apply sha-256-update! x)) ;; Add a bytevector to the state. Align your data to whole blocks if ;; you want this to go a little faster. (define sha-256-update! (case-lambda ((state data start end) (let ((m (sha-state-m state)) ;unprocessed data (H (sha-state-H state)) (W (sha-state-W state))) (let lp ((offset start)) (cond ((eqv? (sha-state-pending state) 64) ;; A whole block is pending (sha-256-transform! H W m 0) (sha-state-pending-set! state 0) (sha-state-processed-set! state (+ 64 (sha-state-processed state))) (lp offset)) ((= offset end) (values)) ((or (> (sha-state-pending state) 0) (> (+ offset 64) end)) ;; Pending data exists or less than a block remains. ;; Add more pending data. (let ((added (min (- 64 (sha-state-pending state)) (- end offset)))) (bytevector-copy! data offset m (sha-state-pending state) added) (sha-state-pending-set! state (+ added (sha-state-pending state))) (lp (+ offset added)))) (else ;; Consume a whole block (sha-256-transform! H W data offset) (sha-state-processed-set! state (+ 64 (sha-state-processed state))) (lp (+ offset 64))))))) ((state data) (sha-256-update! state data 0 (bytevector-length data))))) (define (sha-384-update! . x) (apply sha-512-update! x)) (define sha-512-update! (case-lambda ((state data start end) (let ((m (sha-state-m state)) ;unprocessed data (H (sha-state-H state)) (W (sha-state-W state))) (let lp ((offset start)) (cond ((= (sha-state-pending state) 128) ;; A whole block is pending (sha-512-transform! H W m 0) (sha-state-pending-set! state 0) (sha-state-processed-set! state (+ 128 (sha-state-processed state))) (lp offset)) ((= offset end) (values)) ((or (> (sha-state-pending state) 0) (> (+ offset 128) end)) ;; Pending data exists or less than a block remains. ;; Add more pending data. (let ((added (min (- 128 (sha-state-pending state)) (- end offset)))) (bytevector-copy! data offset m (sha-state-pending state) added) (sha-state-pending-set! state (+ added (sha-state-pending state))) (lp (+ offset added)))) (else ;; Consume a whole block (sha-512-transform! H W data offset) (sha-state-processed-set! state (+ 128 (sha-state-processed state))) (lp (+ offset 128))))))) ((state data) (sha-512-update! state data 0 (bytevector-length data))))) (define zero-block (make-bytevector 128 0)) (define (sha-224-finish! state) (sha-256-finish! state)) ;; Finish the state by adding a 1, zeros and the counter. (define (sha-256-finish! state) (let ((m (sha-state-m state)) (pending (+ (sha-state-pending state) 1))) (bytevector-u8-set! m (sha-state-pending state) #x80) (cond ((> pending 56) (bytevector-copy! zero-block 0 m pending (- 64 pending)) (sha-256-transform! (sha-state-H state) (sha-state-W state) m 0) (bytevector-fill! m 0)) (else (bytevector-copy! zero-block 0 m pending (- 64 pending)))) ;; Number of bits in the data (bytevector-u64-set! m 56 (* (+ (sha-state-processed state) (- pending 1)) 8) (endianness big)) (sha-256-transform! (sha-state-H state) (sha-state-W state) m 0))) (define (sha-384-finish! state) (sha-512-finish! state)) (define (sha-512-finish! state) (let ((m (sha-state-m state)) (pending (+ (sha-state-pending state) 1))) (bytevector-u8-set! m (sha-state-pending state) #x80) (cond ((> pending 112) (bytevector-copy! zero-block 0 m pending (- 128 pending)) (sha-512-transform! (sha-state-H state) (sha-state-W state) m 0) (bytevector-fill! m 0)) (else (bytevector-copy! zero-block 0 m pending (- 128 pending)))) ;; Number of bits in the data (bytevector-uint-set! m 112 (* (+ (sha-state-processed state) (- pending 1)) 8) (endianness big) 16) (sha-512-transform! (sha-state-H state) (sha-state-W state) m 0))) (define (sha-2-finish copy finish!) (lambda (state) (let ((copy (copy state))) (finish! copy) copy))) (define sha-224-finish (sha-2-finish sha-224-copy sha-224-finish!)) (define sha-256-finish (sha-2-finish sha-256-copy sha-256-finish!)) (define sha-384-finish (sha-2-finish sha-384-copy sha-384-finish!)) (define sha-512-finish (sha-2-finish sha-512-copy sha-512-finish!)) ;; Find the message digest of the concatenation of the given bytevectors. (define (sha-2 make update! finish!) (lambda data (let ((state (make))) (for-each (lambda (d) (update! state d)) data) (finish! state) state))) (define sha-224 (sha-2 make-sha-224 sha-224-update! sha-224-finish!)) (define sha-256 (sha-2 make-sha-256 sha-256-update! sha-256-finish!)) (define sha-384 (sha-2 make-sha-384 sha-384-update! sha-384-finish!)) (define sha-512 (sha-2 make-sha-512 sha-512-update! sha-512-finish!)) (define (sha-2/32-copy-hash! len) (lambda (state bv off) (do ((i 0 (+ i 1))) ((= i len)) (bytevector-u32-set! bv (+ off (* 4 i)) (vector-ref (sha-state-H state) i) (endianness big))))) (define sha-224-copy-hash! (sha-2/32-copy-hash! 224/32)) (define sha-256-copy-hash! (sha-2/32-copy-hash! 256/32)) (define sha-224-128-copy-hash! (sha-2/32-copy-hash! 128/32)) (define sha-256-128-copy-hash! (sha-2/32-copy-hash! 128/32)) (define (sha-2/64-copy-hash! len) (lambda (state bv off) (do ((i 0 (+ i 1))) ((= i len)) (bytevector-u64-set! bv (+ off (* 8 i)) (vector-ref (sha-state-H state) i) (endianness big))))) (define sha-384-copy-hash! (sha-2/64-copy-hash! 384/64)) (define sha-512-copy-hash! (sha-2/64-copy-hash! 512/64)) (define sha-384-128-copy-hash! (sha-2/64-copy-hash! 128/64)) (define sha-512-128-copy-hash! (sha-2/64-copy-hash! 128/64)) (define (sha-2->bytevector copy! len) (lambda (state) (let ((ret (make-bytevector (* 4 len)))) (copy! state ret 0) ret))) (define sha-224->bytevector (sha-2->bytevector sha-224-copy-hash! 224/32)) (define sha-256->bytevector (sha-2->bytevector sha-256-copy-hash! 256/32)) (define sha-384->bytevector (sha-2->bytevector sha-384-copy-hash! 384/32)) (define sha-512->bytevector (sha-2->bytevector sha-512-copy-hash! 512/32)) (define (make-sha-2/32->string len) (lambda (state) (define hex \"0123456789abcdef\") (do ((ret (make-string len)) (H (sha-state-H state)) (i 0 (fx+ i 1))) ((fx=? i len) ret) (let ((n (bitwise-and (bitwise-arithmetic-shift-right (vector-ref H (fxarithmetic-shift-right i 3)) (fx- 28 (fx* 4 (fxand i #b111)))) #xf))) (string-set! ret i (string-ref hex n)))))) (define (make-sha-2/64->string len) (lambda (state) (define hex \"0123456789abcdef\") (do ((ret (make-string len)) (H (sha-state-H state)) (i 0 (fx+ i 1))) ((fx=? i len) ret) (let ((n (bitwise-and (bitwise-arithmetic-shift-right (vector-ref H (fxarithmetic-shift-right i 4)) (fx- 60 (fx* 4 (fxand i #b1111)))) #xf))) (string-set! ret i (string-ref hex n)))))) (define sha-224->string (make-sha-2/32->string 224/4)) (define sha-256->string (make-sha-2/32->string 256/4)) (define sha-384->string (make-sha-2/64->string 384/4)) (define sha-512->string (make-sha-2/64->string 512/4)) (define (cmp/32 state bv len) (do ((i 0 (fx+ i 1)) (diff 0 (+ diff (bitwise-xor (bytevector-u32-ref bv (* 4 i) (endianness big)) (vector-ref (sha-state-H state) i))))) ((fx=? i len) (zero? diff)))) (define (sha-224-hash=? state bv) (cmp/32 state bv 224/32)) (define (sha-256-hash=? state bv) (cmp/32 state bv 256/32)) (define (sha-384-hash=? state bv) (cmp/64 state bv 384/64)) (define (sha-512-hash=? state bv) (cmp/64 state bv 512/64)) (define (cmp/64 state bv len) (do ((i 0 (fx+ i 1)) (diff 0 (+ diff (bitwise-xor (bytevector-u64-ref bv (* 8 i) (endianness big)) (vector-ref (sha-state-H state) i))))) ((fx=? i len) (zero? diff)))) (define (sha-224-128-hash=? state bv) (cmp/32 state bv 128/32)) (define (sha-256-128-hash=? state bv) (cmp/32 state bv 128/32)) (define (sha-384-128-hash=? state bv) (cmp/64 state bv 128/64)) (define (sha-512-128-hash=? state bv) (cmp/64 state bv 128/64)) (define hmac-sha-224 (make-hmac 64 sha-224 sha-224->bytevector make-sha-224 sha-224-update! sha-224-finish! sha-224-clear!)) (define hmac-sha-256 (make-hmac 64 sha-256 sha-256->bytevector make-sha-256 sha-256-update! sha-256-finish! sha-256-clear!)) (define hmac-sha-384 (make-hmac 128 sha-384 sha-384->bytevector make-sha-384 sha-384-update! sha-384-finish! sha-384-clear!)) (define hmac-sha-512 (make-hmac 128 sha-512 sha-512->bytevector make-sha-512 sha-512-update! sha-512-finish! sha-512-clear!))) ") ("bootar/compression") ("bootar/compression/gzip.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2010, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; GZIP file format reader ;; RFC1952: GZIP file format specification version 4.3 ;; http://www.gzip.org/format.txt ;; This library ignores FTEXT and OS and always treats data as binary. ;; The \"extra\" data in the header is also ignored. Only DEFLATEd data ;; is supported. ;; TODO: reduce maximum memory usage (see the note about call/cc) (library (compression gzip) (export make-gzip-input-port open-gzip-file-input-port extract-gzip is-gzip-file? get-gzip-header gzip-text? gzip-mtime gzip-extra-data gzip-filename gzip-comment gzip-method gzip-os) (import (rnrs) (srfi :19 time) (compression inflate) (compression private common) (hashing crc) (struct pack)) (define-crc crc-32) (define-record-type gzip (fields text? mtime extra-data filename comment method os)) (define (flg-ftext? x) (fxbit-set? x 0)) (define (flg-fhcrc? x) (fxbit-set? x 1)) (define (flg-fextra? x) (fxbit-set? x 2)) (define (flg-fname? x) (fxbit-set? x 3)) (define (flg-fcomment? x) (fxbit-set? x 4)) (define (flg-reserved? x) (not (fxzero? (fxbit-field x 6 8)))) (define compression-method-deflate 8) (define gzip-magic #vu8(#x1f #x8b)) (define (get-asciiz p) (call-with-string-output-port (lambda (r) (let lp () (let ((b (get-u8 p))) (unless (fxzero? b) (put-char r (integer->char b)) (lp))))))) (define (is-gzip-file? f) (let* ((f (if (input-port? f) f (open-file-input-port f))) (pos (port-position f))) (set-port-position! f 0) (let ((bv (get-bytevector-n f 2))) (set-port-position! f pos) (equal? bv gzip-magic)))) (define (get-gzip-header* p who) (let*-values (((cm flg mtime xfl os) (get-unpack p \"date (make-time 'time-monotonic 0 mtime))) extra fname fcomment (if (= xfl 2) 'slowest (if (= xfl 4) 'fastest xfl)) os))) (define get-gzip-header (case-lambda ((p) (get-gzip-header p 'get-gzip-header)) ((p who) (unless (eqv? (lookahead-u8 p) #x1f) (error who \"not GZIP data\" p)) (get-u8 p) (unless (eqv? (lookahead-u8 p) #x8b) (error who \"not GZIP data\" p)) (get-u8 p) (get-gzip-header* p who)))) (define (get-crc in bv*) ;; The bv* is taken from the bit-reader state for the inflater. (let ((len (- (format-size \" (+ offsetw count) (bytevector-length buffer)) (let ((new (make-bytevector (* 2 (bytevector-length buffer))))) (bytevector-copy! buffer offsetr new 0 (- offsetw offsetr)) (set! offsetw (- offsetw offsetr)) (set! offsetr 0) (set! buffer new) (lp)))) (bytevector-copy! bv start buffer offsetw count) (set! offsetw (+ offsetw count))) (define inflater (make-inflater in sink 32768 #f)) (define (read! bytevector start count) ;; Read up to `count' bytes from the source, write them to ;; `bytevector' at index `start'. Return the number of bytes ;; read (zero means end of file). (define (return) (let* ((valid (- offsetw offsetr)) (returned (min count valid))) (bytevector-copy! buffer offsetr bytevector start returned) (cond ((= returned valid) (set! offsetr 0) (set! offsetw 0)) (else (set! offsetr (+ offsetr returned)))) returned)) (cond ((zero? offsetw) (if (or last-member (port-eof? in)) 0 (let lp () (case (inflater) ((more) ;more deflate blocks available (if (zero? offsetw) (lp) ;encountered a sync block (return))) ((done) ;end of deflate data (let ((expect (crc-32-finish checksum)) (actual (get-crc in (inflater 'get-buffer)))) (unless (eqv? expect actual) (error 'gzip-read! \"bad GZIP checksum\" expect actual))) (let ((expect (get-unpack in \" ;; Copyright (C) 2010, 2011, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Author: Andreas Rottmann ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. ;;; Commentary: ;; Modified on 2010-04-17 by Göran Weinholt ;; Fixed a bug where sliding-buffer-dup! would try to do a ;; bytevector-copy! beyond the end of sliding-buffer-data. Also ;; implemented sliding-buffer-init! for use by ZLIB's pre-set ;; dictionaries. ;; Modified on 2011-09-04 by Göran Weinholt ;; Added the sliding-buffer-lookback-u8 procedure, which returns ;; the byte located a distance away from the current position. ;;; Code: #!r6rs (library (compression sliding-buffer) (export make-sliding-buffer sliding-buffer? sliding-buffer-init! sliding-buffer-drain! sliding-buffer-read! sliding-buffer-put-u8! sliding-buffer-lookback-u8 sliding-buffer-dup!) (import (rnrs)) (define-record-type sliding-buffer (protocol (lambda (p) (lambda (sink size) (p sink (make-bytevector size) 0 0)))) (fields sink data (mutable fill) (mutable pos))) (define (sliding-buffer-size buffer) (bytevector-length (sliding-buffer-data buffer))) ;; Copy data into the buffer so that it can be dup!'d. The sink does ;; not receive this data. (define (sliding-buffer-init! buffer bv) (let ((data (sliding-buffer-data buffer)) (len (bytevector-length bv))) (bytevector-copy! bv 0 data 0 len) (sliding-buffer-pos-set! buffer len))) (define (%sliding-buffer-drain buffer pos fill) (let ((sink (sliding-buffer-sink buffer)) (size (sliding-buffer-size buffer)) (data (sliding-buffer-data buffer))) (let loop ((i (fxmod (fx- pos fill) size)) (fill fill)) (when (fx>? fill 0) (let ((count (fxmin fill (fx- size i)))) (sink data i count) (loop (fxmod (fx+ i count) size) (fx- fill count))))))) (define (sliding-buffer-drain! buffer) (%sliding-buffer-drain buffer (sliding-buffer-pos buffer) (sliding-buffer-fill buffer)) (sliding-buffer-fill-set! buffer 0)) (define (sliding-buffer-read! buffer in-port len) (let ((size (sliding-buffer-size buffer)) (data (sliding-buffer-data buffer))) (let loop ((pos (sliding-buffer-pos buffer)) (fill (sliding-buffer-fill buffer)) (n-left len)) (cond ((fx=? 0 n-left) (sliding-buffer-pos-set! buffer pos) (sliding-buffer-fill-set! buffer fill) len) ((fx=? fill size) (%sliding-buffer-drain buffer pos fill) (loop pos 0 n-left)) (else (let ((count (fxmin (fx- size fill) (fx- size pos) n-left))) (let ((n-read (get-bytevector-n! in-port data pos count))) (cond ((eof-object? n-read) (sliding-buffer-pos-set! buffer pos) (sliding-buffer-fill-set! buffer fill) (if (fx=? n-left len) (eof-object) (- len n-left))) (else (loop (fxmod (fx+ pos n-read) size) (fx+ fill n-read) (fx- n-left n-read))))))))))) (define (sliding-buffer-put-u8! buffer u8) (let ((size (sliding-buffer-size buffer))) (when (fx=? (sliding-buffer-fill buffer) size) (sliding-buffer-drain! buffer)) (let ((pos (sliding-buffer-pos buffer)) (data (sliding-buffer-data buffer))) (bytevector-u8-set! (sliding-buffer-data buffer) pos u8) (sliding-buffer-pos-set! buffer (fxmod (fx+ pos 1) size)) (sliding-buffer-fill-set! buffer (fx+ (sliding-buffer-fill buffer) 1))))) (define (sliding-buffer-lookback-u8 buffer distance) (let ((size (sliding-buffer-size buffer)) (fill (sliding-buffer-fill buffer))) (let ((pos (fxmod (fx- (sliding-buffer-pos buffer) distance) size)) (data (sliding-buffer-data buffer))) (bytevector-u8-ref (sliding-buffer-data buffer) pos)))) (define (sliding-buffer-dup! buffer distance len) (let ((size (sliding-buffer-size buffer)) (data (sliding-buffer-data buffer))) (assert (< 0 distance (fx+ size 1))) (cond ((< distance len) (sliding-buffer-dup! buffer distance distance) (sliding-buffer-dup! buffer distance (fx- len distance))) (else (let loop ((i (mod (fx- (sliding-buffer-pos buffer) distance) size)) (pos (sliding-buffer-pos buffer)) (fill (sliding-buffer-fill buffer)) (n-left len)) (cond ((fx=? 0 n-left) (sliding-buffer-pos-set! buffer pos) (sliding-buffer-fill-set! buffer fill)) ((fx=? fill size) (%sliding-buffer-drain buffer pos fill) (loop i pos 0 n-left)) (else (let ((count (fxmin (fx- size i) (fx- size fill) n-left (fx- size pos)))) (bytevector-copy! data i data pos count) (loop (fxmod (fx+ i count) size) (fxmod (fx+ pos count) size) (fx+ fill count) (fx- n-left count))))))))))) ") ("bootar/compression/huffman.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2009, 2010, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; Procedures for David Huffman's codes. These are suitable for use ;; with DEFLATE. (library (compression huffman) (export reconstruct-codes canonical-codes->simple-lookup-table canonical-codes->lookup-table canonical-codes->big-endian-lookup-table get-next-code) (import (except (rnrs) fxreverse-bit-field) (compression bitstream) (compression private compat)) (define-syntax trace (syntax-rules () #; ((_ . args) (begin (for-each display (list . args)) (newline))) ((_ . args) (begin 'dummy)))) (define-syntax revtable (lambda (x) (define (rev v start end) (do ((i start (fx+ i 1)) (ret 0 (if (fxbit-set? v i) (fxior ret (fxarithmetic-shift-left 1 (fx- (fx- end i) 1))) ret))) ((fx=? i end) (fxior (fxarithmetic-shift-left ret start) (fxcopy-bit-field v start end 0))))) (syntax-case x () ((table bits) (let* ((bits (syntax->datum #'bits)) (len (fxarithmetic-shift-left 1 bits))) (do ((v (make-vector len)) (i 0 (+ i 1))) ((= i len) (with-syntax ((t v)) #'(begin 't))) (vector-set! v i (rev i 0 bits)))))))) (define (reverse-bits i end) (define rev9 (revtable 9)) (if (fx<=? end 9) (fxarithmetic-shift-right (vector-ref rev9 i) (fx- 9 end)) (fxreverse-bit-field i 0 end))) ;; If you have a canonical Huffman tree, with a known alphabet, then ;; all that is needed to reconstruct the tree is the length of each ;; symbol in the alphabet. This procedure takes a list of ((symbol . ;; bit-length) ...) and computes the codes. (define (reconstruct-codes sym< syms+lens) ;; The canonical codes are described in RFC 1951 section 3.2.2. ;; Don't try to read their code though... (define (sort-by-length x) (list-sort (lambda (x y) (< (cdr x) (cdr y))) x)) (define (sort-by-alphabet x) (list-sort (lambda (x y) (sym< (car x) (car y))) x)) (let lp ((code 0) (syms+lens (sort-by-length syms+lens)) (ret '())) (let ((sym+len+code (list (caar syms+lens) (cdar syms+lens) code))) (if (null? (cdr syms+lens)) (sort-by-alphabet (cons sym+len+code ret)) (lp (bitwise-arithmetic-shift-left (+ code 1) (- (cdadr syms+lens) (cdar syms+lens))) (cdr syms+lens) (cons sym+len+code ret)))))) ;; (reconstruct-codes charhuffman-tree < freqs) ;; ;; TODO: linear time? ;; (define (sort freqs) ;; (list-sort (lambda (x y) (< (car x) (car y))) ;; freqs)) ;; (if (null? (cdr freqs)) ;; (cdar freqs) ;; (let* ((freqs (sort freqs)) ;; (node (cond ((< (depth (cdar freqs)) (depth (cdadr freqs))) ;help make it unique ;; (cons (cdar freqs) (cdadr freqs))) ;; (else ;; (cons (cdadr freqs) (cdar freqs))))) ;; (weight (+ (caar freqs) (caadr freqs)))) ;; (frequencies->huffman-tree < (cons (cons weight node) ;; (cddr freqs)))))) ;; (define (flatten-huffman-tree tree) ;; ;; Turns a binary tree into a list of (symbol length code). ;; (define (flatten t len code) ;; (cond ;; ((pair? t) ;; (append (flatten (car t) (+ len 1) (bitwise-arithmetic-shift-left code 1)) ;; (flatten (cdr t) (+ len 1) (bitwise-ior 1 (bitwise-arithmetic-shift-left code 1))))) ;; (else ;; (list (list t len code))))) ;; (flatten tree 0 0)) ;; Turns a Huffman tree into a list of (symbol length code), where ;; the code is the canonical code. ;; (define (huffman-tree->canonical-codes symsimple-lookup-table codes) (let ((maxlen (fold-right max 0 (map cadr codes)))) (do ((t (make-vector (fxarithmetic-shift-left 1 maxlen) #f)) (codes codes (cdr codes))) ((null? codes) (cons maxlen t)) (let* ((code (car codes)) (symbol (car code)) (bitlen (cadr code)) (bits (caddr code)) (translation (cons bitlen symbol))) (let* ((start (fxarithmetic-shift-left bits (- maxlen bitlen))) (end (fxior start (- (fxarithmetic-shift-left 1 (- maxlen bitlen)) 1)))) (do ((i start (fx+ i 1))) ((fx>? i end)) (vector-set! t (fxreverse-bit-field i 0 maxlen) translation))))))) ;; (canonical-codes->simple-lookup-table ;; '((#\\A 3 2) (#\\B 3 3) (#\\C 3 4) (#\\D 3 5) (#\\E 3 6) (#\\F 2 0) (#\\G 4 14) (#\\H 4 15))) ;; Uses two tables, as described here: http://www.gzip.org/algorithm.txt (define (%canonical-codes->lookup-table codes big-endian?) (define maxlen ;; Length of the first table. 9 is a sweet spot, but causes ;; trouble because it can consume a byte too much in lookahead ;; (like at the end of a gzip stream). (let lp ((m 1) (codes codes)) (if (null? codes) m (let ((bitlen (cadar codes))) (if (fx>=? bitlen 8) 9 (lp (max m bitlen) (cdr codes))))))) (define (findmax codes prefix) ;; Find the maximum code length for codes where the first ;; `maxlen' bits are equal to the prefix. (let lp ((m 0) (codes codes)) (if (null? codes) m (let ((bitlen (cadar codes)) (bits (caddar codes))) (cond ((fx>? maxlen bitlen) (lp m (cdr codes))) ((fx=? (fxarithmetic-shift-right bits (fx- bitlen maxlen)) prefix) (lp (max m (fx- bitlen maxlen)) (cdr codes))) (else (lp m (cdr codes)))))))) (define (fill! t bits maxlen bitlen translation) (let* ((start (fxarithmetic-shift-left bits (fx- maxlen bitlen))) (end (fxior start (fx- (fxarithmetic-shift-left 1 (fx- maxlen bitlen)) 1)))) (trace \"#;start: #b\" (string-pad (number->string start 2) bitlen #\\0)) (trace \"#;end: #b\" (string-pad (number->string end 2) bitlen #\\0)) (do ((i start (fx+ i 1))) ((fx>? i end)) (trace `(set! ,i ,translation)) (vector-set! t (if big-endian? i (reverse-bits i maxlen)) translation)))) (do ((t (make-vector (fxarithmetic-shift-left 1 maxlen) #f)) (codes codes (cdr codes))) ((null? codes) (cons maxlen t)) (let* ((code (car codes)) (symbol (car code)) (bitlen (cadr code)) (bits (caddr code))) (trace \"#;symbol: \" symbol \" #;bitlen: \"bitlen \" #;bits: #b\" (string-pad (number->string bits 2) bitlen #\\0)) (if (fx<=? bitlen maxlen) (fill! t bits maxlen bitlen (cons bitlen symbol)) (let* ((bitlen (fx- bitlen maxlen)) ;bitlength in table 2 (i (fxarithmetic-shift-right bits bitlen)) (ri (if big-endian? i (reverse-bits i maxlen))) (t2 (cond ((vector-ref t ri) => cdr) (else ;; make a second-level table (let* ((maxlen* (findmax codes i)) (v (make-vector (fxarithmetic-shift-left 1 maxlen*) #f)) (t2 (cons maxlen* v))) (trace `(set! ,i table)) (vector-set! t ri (cons maxlen t2)) t2)))) (bits (fxand bits (fx- (fxarithmetic-shift-left 1 bitlen) 1)))) (fill! (data t2) bits (len t2) bitlen (cons bitlen symbol))))))) (define (canonical-codes->lookup-table codes) (%canonical-codes->lookup-table codes #f)) (define (canonical-codes->big-endian-lookup-table codes) (%canonical-codes->lookup-table codes #t)) ;; (flatten-huffman-tree '((1 4 . 3) (5 7 10 . 9) 2 (6 . 11) 8 12 . 13)) (define len car) (define data cdr) ;; This lookup code is the companion of the procedure above. (define (get-next-code br table) (let ((code (lookahead-bits br (len table)))) (let ((translation (vector-ref (data table) code))) (trace \"code: \" (string-pad (number->string code 2) (len translation) #\\0) \" => \" (data translation)) (get-bits br (len translation)) (if (pair? (data translation)) (get-next-code br (data translation)) (data translation)))))) ") ("bootar/compression/tar.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2010, 2012, 2017, 2018, 2019 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; Procedures that read Tape ARchives ;; (get-header-record binary-input-port) ;; Reads a tar header and does a checksum verification. Returns the ;; end of file object when there are no more files in the archive. ;; The returned object should be inspected with the header-* ;; procedures, unless you're asking for trouble. After this call you ;; should use extract-to-port or skip-file, even if it's not a ;; regular file. ;; (extract-to-port binary-input-port header binary-output-port) ;; Call this after get-header-record to extract the file to a port. ;; After this call you can use get-header-record again. ;; (skip-file binary-input-port header) ;; Works like extract-to-port, but it does not write the file anywhere. ;; (header-name header) ;; Returns the filename of the file immediately following the header ;; in the tape archive. ;; (header-typeflag header) ;; Returns one of these symbols: regular hardlink symlink char block ;; directory fifo. Only 'regular should contain any extractable data. ;; (header-linkname header) ;; For files where the typeflag is 'symlink, this indicates where ;; the symlink points. ;; ... ;; http://www.gnu.org/software/tar/manual/html_section/Formats.html (library (compression tar) (export get-header-record header-name header-mode header-uid header-gid header-size header-mtime header-chksum header-typeflag header-linkname header-magic header-version header-uname header-gname header-devmajor header-devminor header-chksum-ok? header-chksum-calculate extract-to-port skip-file) (import (rnrs) (only (srfi :13 strings) string-trim-both string-trim-right) (only (srfi :19 time) time-monotonic->date make-time)) (define-syntax trace (syntax-rules () #; ((_ . args) (begin (for-each display (list . args)) (newline))) ((_ . args) (begin 'dummy)))) (define (get-asciiz bv i max) (utf8->string (call-with-bytevector-output-port (lambda (r) (let lp ((i i) (max max)) (unless (zero? max) (let ((b (bytevector-u8-ref bv i))) (unless (fxzero? b) (put-u8 r b) (lp (fx+ i 1) (fx- max 1)))))))))) (define (get-octal bv i max) (string->number (string-trim-both (get-asciiz bv i max)) 8)) (define zero-record (make-bytevector 512 0)) (define (zero-record? rec) (bytevector=? (rec-bv rec) zero-record)) (define (premature-eof who tarport) (error who \"premature end of archive\" tarport)) (define (rec-ref name rec) (cond ((bytevector? rec) #f) ((assq name rec) => cdr) (else #f))) (define (rec-bv rec) (if (bytevector? rec) rec (cdr (assq 'bv rec)))) ;;; Header accessors ;; Please use these header accessors and do not rely on type of the ;; object returned by get-header-record. (define (header-name rec) (or (rec-ref 'path rec) (get-asciiz (rec-bv rec) 0 100))) (define (header-mode rec) (get-octal (rec-bv rec) 100 8)) (define (header-uid rec) (get-octal (rec-bv rec) 108 8)) (define (header-gid rec) (get-octal (rec-bv rec) 116 8)) (define (header-size rec) (get-octal (rec-bv rec) 124 12)) (define (header-mtime rec) (time-monotonic->date (make-time 'time-monotonic 0 (get-octal (rec-bv rec) 136 12)))) (define (header-chksum rec) (get-octal (rec-bv rec) 148 8)) (define (header-typeflag rec) (let ((t (integer->char (bytevector-u8-ref (rec-bv rec) 156)))) (case t ((#\\0 #\\nul) 'regular) ((#\\1) 'hardlink) ((#\\2) 'symlink) ((#\\3) 'char) ((#\\4) 'block) ((#\\5) 'directory) ((#\\6) 'fifo) ;; Regular file with \"high-performance attribute\"? ((#\\7) 'regular) (else t)))) (define (header-linkname rec) (or (rec-ref 'linkpath rec) (get-asciiz (rec-bv rec) 157 100))) (define (header-magic rec) (get-asciiz (rec-bv rec) 257 6)) (define (header-version rec) (get-octal (rec-bv rec) 263 2)) (define (header-uname rec) (get-asciiz (rec-bv rec) 265 32)) (define (header-gname rec) (get-asciiz (rec-bv rec) 297 32)) (define (header-devmajor rec) (get-octal (rec-bv rec) 329 8)) (define (header-devminor rec) (get-octal (rec-bv rec) 337 8)) (define (header-chksum-calculate rec) (define (sum bv start end) (do ((i start (fx+ i 1)) (sum 0 (fx+ sum (bytevector-u8-ref bv i)))) ((fx=? i end) sum))) (fx+ (sum (rec-bv rec) 0 148) (fx+ 256 #;(sum #vu8(32 32 32 32 32 32 32 32) 0 8) (sum (rec-bv rec) 156 512)))) (define (header-chksum-ok? rec) (eqv? (header-chksum (rec-bv rec)) (header-chksum-calculate (rec-bv rec)))) ;;; Tarball reading ;; TODO: PAX global header (g)? (define (extract-to-bytevector tarport header) (call-with-bytevector-output-port (lambda (p) (extract-to-port tarport header p)))) (define (parse-pax-header header value->string) (define (get/sentinel port sentinel valid?) (let lp ((chars '())) (let ((b (get-u8 port))) (cond ((eof-object? b) (eof-object)) ((fx=? b (char->integer sentinel)) (list->string (reverse chars))) ((valid? b) (lp (cons (integer->char b) chars))) (else (eof-object)))))) (call-with-port (open-bytevector-input-port (rec-bv header)) (lambda (p) (let lp ((attr* '())) (let* ((len (get/sentinel p #\\space (lambda (b) (fx<=? (char->integer #\\0) b (char->integer #\\9))))) (key (get/sentinel p #\\= (lambda _ _)))) (if (eof-object? len) attr* (let* ((value-len (- (string->number len 10) 1 ; (string-length len) 1 ; (string-length key) 1)) ; (value (get-bytevector-n p value-len)) (newline (get-u8 p))) (unless (and (bytevector? value) (= (bytevector-length value) value-len) (eqv? newline (char->integer #\\newline))) (error 'parse-pax-header \"Invalid PAX header\" value value-len newline)) (cons (cons (string->symbol key) (value->string value)) (lp attr*))))))))) (define (get-header-record tarport) (define who 'get-header-record) (let ((rec (get-bytevector-n tarport 512))) (trace \"get-header-record\") (cond ((eof-object? rec) (eof-object)) ((zero-record? rec) (eof-object)) ((not (= (bytevector-length rec) 512)) (premature-eof who tarport)) ((not (header-chksum-ok? rec)) (error who \"bad tar header checksum\" tarport)) ((and (eqv? (header-typeflag rec) #\\L) (equal? (header-name rec) \"././@LongLink\")) (trace \"reading gnu L\") (let* ((data (extract-to-bytevector tarport rec)) (path (string-trim-right (utf8->string data) #\\nul))) `((path . ,path) ,@(get-header-record tarport)))) ((and (eqv? (header-typeflag rec) #\\K) (equal? (header-name rec) \"././@LongLink\")) (trace \"reading gnu K\") (let* ((data (extract-to-bytevector tarport rec)) (linkpath (string-trim-right (utf8->string data) #\\nul))) `((linkpath . ,linkpath) ,@(get-header-record tarport)))) ((eqv? (header-typeflag rec) #\\x) (trace \"reading pax header\") (let ((pax-data (extract-to-bytevector tarport rec))) ;; (hexdump #f pax-data) ;; TODO: the global header might specify something other than utf8 (append (parse-pax-header pax-data utf8->string) (get-header-record tarport)))) (else `((bv . ,rec)))))) (define (extract-to-port tarport header destport) (define who 'extract-to-port) (trace \"Extracting \" (header-name header) \" (\" (header-size header) \") bytes\" \" from \" tarport \" to \" destport) (let*-values (((size) (header-size header)) ((blocks trail) (div-and-mod size 512))) (trace blocks \" blocks and \" trail \" bytes trailing\") (do ((buf (make-bytevector 512)) (blocks blocks (- blocks 1))) ((zero? blocks) (unless (zero? trail) (let ((r (get-bytevector-n! tarport buf 0 512))) (trace \"read block: \" r \" (last)\") (unless (eqv? r 512) (premature-eof who tarport)) (put-bytevector destport buf 0 trail)))) (let ((r (get-bytevector-n! tarport buf 0 512))) (unless (eqv? r 512) (premature-eof who tarport)) (trace \"read block: \" r) (put-bytevector destport buf))))) (define (skip-file tarport header) (define who 'skip-file) (trace \"Skipping \" (header-name header) \" from \" tarport) (let ((blocks (div (+ 511 (header-size header)) 512))) (trace blocks \" blocks\") (cond ((eq? 'hardlink (header-typeflag header))) ((and (port-has-port-position? tarport) (port-has-set-port-position!? tarport)) (set-port-position! tarport (+ (port-position tarport) (* 512 blocks)))) (else (do ((buf (make-bytevector 512)) (blocks blocks (- blocks 1))) ((zero? blocks)) (let ((r (get-bytevector-n! tarport buf 0 512))) (unless (eqv? r 512) (premature-eof who tarport)) (trace \"read block: \" r)))))))) ") ("bootar/compression/private") ("bootar/compression/private/common.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs (library (compression private common) (export bytevector-append bytevector->uint) (import (rnrs (6))) (define (bytevector-append . bvs) (call-with-bytevector-output-port (lambda (p) (for-each (lambda (bv) (put-bytevector p bv)) bvs)))) (define (bytevector->uint bv) (if (zero? (bytevector-length bv)) 0 (bytevector-uint-ref bv 0 (endianness big) (bytevector-length bv))))) ") ("bootar/compression/private/compat.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs (library (compression private compat) (export fxreverse-bit-field) (import (only (rnrs) fxreverse-bit-field))) ") ("bootar/compression/inflate.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2009, 2010, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; INFLATE is the decompression of DEFLATE'd data (RFC1951) ;; DEFLATE uses a combination of Huffman coding and LZ77. Huffman ;; coding takes an alphabet and makes it into a binary tree where ;; symbols that are more common have a shorter path from the top of ;; the tree (they are sort of like Morse codes). LZ77 makes it ;; possible to copy parts of the recently decompressed data. (library (compression inflate) (export inflate make-inflater) (import (rnrs) (compression bitstream) (compression huffman) (compression sliding-buffer) (only (srfi :1 lists) iota)) (define-syntax trace (syntax-rules () #; ((_ . args) (begin (for-each display (list . args)) (newline))) ((_ . args) (begin 'dummy)))) (define vector->huffman-lookup-table (case-lambda ((codes) (vector->huffman-lookup-table codes 0 (vector-length codes))) ((codes start end) (do ((i (fx- end 1) (fx- i 1)) (l '() (if (fxzero? (vector-ref codes i)) l ;zeros don't count (cons (cons (fx- i start) (vector-ref codes i)) l)))) ((fxlookup-table (reconstruct-codes < l))))))) (define static-table2 (vector->huffman-lookup-table (list->vector (map (lambda (c) (cond ((< c 144) 8) ((< c 256) 9) ((< c 280) 7) (else 8))) (iota 288))))) (define static-table3 (vector->huffman-lookup-table (make-vector 32 5))) (define len-extra '#(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0)) (define len-base '#(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258)) (define dist-extra '#(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13)) (define dist-base '#(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577)) (define (inflate-cblock buffer br table2 table3) (let lp () (let ((code (get-next-code br table2))) (cond ((< code 256) ;literal byte (trace \"LITERAL:\" code) (sliding-buffer-put-u8! buffer code) (lp)) ((<= 257 code 285) (trace \"\\nlen code: \" code) (let* ((len (+ (get-bits br (vector-ref len-extra (- code 257))) (vector-ref len-base (- code 257)))) (distcode (get-next-code br table3)) (dist (+ (get-bits br (vector-ref dist-extra distcode)) (vector-ref dist-base distcode)))) (trace \"len: \" len \" dist: \" dist) (trace \"COPYING FROM POSITION: \" dist \" THIS MUCH: \" len) (sliding-buffer-dup! buffer dist len) (lp))) ((= 256 code)) ;end of block (else (error 'inflate \"error in compressed data (bad literal/length)\")))))) (define (inflate-block in buffer br) (case (get-bits br 2) ;block-type ((#b00) ;non-compressed block (align-bit-reader br) ;seek to a byte boundary (let* ((len (get-bits br 16)) (nlen (get-bits br 16))) (trace \"non-compressed block: \" len) (unless (fx=? len (fxand #xffff (fxnot nlen))) (error 'inflate \"error in non-compressed block length\" len nlen)) (unless (eqv? len (sliding-buffer-read! buffer in len)) (error 'inflate \"premature EOF encountered\")))) ((#b01) ;static Huffman tree (trace \"block with static Huffman tree\") (inflate-cblock buffer br static-table2 static-table3)) ((#b10) ;dynamic Huffman tree (trace \"block with dynamic Huffman tree\") (let* ((hlit (fx+ 257 (get-bits br 5))) (hdist (fx+ 1 (get-bits br 5))) (hclen (fx+ 4 (get-bits br 4)))) (when (or (fx>? hlit 286) (fx>? hclen 19)) (error 'inflate \"bad number of literal/length codes\" hlit hclen)) ;; Up to 19 code lengths are now read... (let ((table1 (do ((order '#(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15)) (i 0 (fx+ i 1)) (codes (make-vector 19 0))) ((fx=? i hclen) ;; The 19 codes represent a canonical ;; Huffman table. (vector->huffman-lookup-table codes)) (vector-set! codes (vector-ref order i) (get-bits br 3))))) ;; Table 1 is now used to encode the `code-lengths' ;; canonical Huffman table. (let* ((hlen (fx+ hlit hdist)) (code-lengths (make-vector hlen 0))) (let lp ((n 0)) (unless (fx=? n hlen) (let ((blc (get-next-code br table1))) (cond ((fxhuffman-lookup-table code-lengths 0 hlit)) (table3 (vector->huffman-lookup-table code-lengths hlit hlen))) (inflate-cblock buffer br table2 table3)))))) ((#b11) (error 'inflate \"error in compressed data (bad block type)\")))) ;; Inflate a complete DEFLATE stream. in and out are binary ports. ;; Returns the output's CRC and length. (define (inflate in out crc-init crc-update crc-finish) (let* ((crc (crc-init)) (output-len 0) (buffer (make-sliding-buffer (lambda (bytevector start count) (put-bytevector out bytevector start count) (set! crc (crc-update crc bytevector start (+ start count))) (set! output-len (+ output-len count))) (* 32 1024))) (br (make-bit-reader in))) (let lp () (let ((last-block (fx=? (get-bits br 1) 1))) (inflate-block in buffer br) (cond (last-block (sliding-buffer-drain! buffer) (align-bit-reader br) (values (crc-finish crc) output-len (get-bit-reader-buffer br))) (else (lp))))))) ;; Returns a procedure that, when called, reads a block from the ;; DEFLATE stream. The dictionary is a bytevector that is pre-loaded ;; into the sliding buffer, but is not copied to the output. (define (make-inflater in sink window-size dictionary) (let ((buffer (make-sliding-buffer sink window-size)) (br (make-bit-reader in))) (when dictionary (sliding-buffer-init! buffer dictionary)) (case-lambda (() (let ((last-block (fx=? (get-bits br 1) 1))) (inflate-block in buffer br) (sliding-buffer-drain! buffer) (if last-block 'done 'more))) ((x) (case x ((get-buffer) ;; Inflate needs a little lookahead sometimes, so a byte ;; or two might be read that does not belong to the ;; deflate stream. This retreives those bytes. (align-bit-reader br) (get-bit-reader-buffer br)))))))) ") ("bootar/compression/bitstream.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2010, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; Read bits from binary input ports. (library (compression bitstream) (export make-bit-reader make-bzip2-bit-reader get-bits lookahead-bits align-bit-reader get-bit-reader-buffer) (import (rnrs)) ;; (define-record-type bit-reader ;; (fields (immutable port) ;; (mutable buf) ;; (mutable buflen)) ;; (protocol ;; (lambda (p) ;; (lambda (port) ;; (p port 0 0))))) ;; Records are too slow in Ikarus... (define (make-bit-reader port) (vector port 0 0 'deflate)) (define (make-bzip2-bit-reader port) (vector port 0 0 'bzip2)) (define (bit-reader-port br) (vector-ref br 0)) (define (bit-reader-buf br) (vector-ref br 1)) (define (bit-reader-buflen br) (vector-ref br 2)) (define (bit-reader-style br) (vector-ref br 3)) (define (bit-reader-buf-set! br v) (vector-set! br 1 v)) (define (bit-reader-buflen-set! br v) (vector-set! br 2 v)) (define (fill! br n) (let lp () (let ((buflen (bit-reader-buflen br))) (when (fx ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; Decoder for Igor Pavlov's LZMA format. ;; This hasn't been tested with LZMA1 streams. (library (compression lzma) (export lzma-decode-chunk) (import (rnrs) (compression sliding-buffer) (compression private common)) (define-syntax trace (syntax-rules () #; ((_ . args) (begin (for-each display (list . args)) (newline))) ((_ . args) (begin 'dummy)))) (define (lzma-decode-chunk in dictionary usize lc lp pb position) (define asl bitwise-arithmetic-shift-left) (define asr bitwise-arithmetic-shift-right) (define fxasl fxarithmetic-shift-left) (define fxasr fxarithmetic-shift-right) ;; Range coding. This can use fixnums if fixnum-width can fit ;; 32-bit unsigned integers. (define rc-top-bits 24) (define rc-model-total-bits 11) (define rc-bit-model-total (expt 2 rc-model-total-bits)) (define rc-shift-bits 5) ;; Range coding state (define rc.code) (define rc.range) (define rc.bound) (define (make-bit-model n) ;; The vector contains integers that represent probabilities. (make-vector n (expt 2 (- rc-model-total-bits 1)))) (define (rc-reset) (set! rc.code (bytevector->uint (get-bytevector-n in 5))) (set! rc.range #xFFFFFFFF) (set! rc.bound 0)) (define (rc-normalize) (when (< rc.range (expt 2 rc-top-bits)) (set! rc.range (asl rc.range 8)) (set! rc.code (bitwise-and #xFFFFFFFF (bitwise-ior (get-u8 in) (asl rc.code 8)))) (trace \"rc-normalize\"))) (define (rc-zero? P i) (rc-normalize) (let ((Pi (vector-ref P i))) (set! rc.bound (* Pi (asr rc.range rc-model-total-bits))) (trace \";; \" (if (< rc.code rc.bound) 'ZERO 'one) \". code: \" rc.code \" bound: \" rc.bound) ;; Update probabilities (cond ((< rc.code rc.bound) (set! rc.range rc.bound) (vector-set! P i (fx+ Pi (fxasr (fx- rc-bit-model-total Pi) rc-shift-bits))) #t) (else (set! rc.range (- rc.range rc.bound)) (set! rc.code (- rc.code rc.bound)) (vector-set! P i (fx- Pi (fxasr Pi rc-shift-bits))) #f)))) (define (rc-get-bit P i mi) (if (rc-zero? P i) (asl mi 1) (bitwise-ior (asl mi 1) #b1))) (define (rc-get-bit* P i mi) (if (rc-zero? P i) (values 0 (asl mi 1)) (values 1 (bitwise-ior (asl mi 1) #b1)))) (define (rc-bit-tree-decode P i bits) (do ((ret 1 (rc-get-bit P (+ i ret) ret)) (j bits (fx- j 1))) ((fxzero? j) (- ret (asl 1 bits))))) (define (rc-direct-bit) (rc-normalize) (set! rc.range (asr rc.range 1)) (cond ((>= rc.code rc.range) (set! rc.code (- rc.code rc.range)) 1) (else 0))) ;; States (define state.literal->literal 0) (define state.match->literal->literal 1) (define state.repeat->literal->literal 2) (define state.short-repeat->literal->literal 3) (define state.match->literal 4) (define state.repeat->literal 5) (define state.short-repeat->literal 6) (define state.literal->match 7) (define state.literal->long-repeat 8) (define state.literal->short-repeat 9) (define state.non-literal->match 10) (define state.non-literal->repeat 11) (define number-of-states (+ state.non-literal->repeat 1)) (define (literal-state? state) (fx<=? state state.short-repeat->literal)) (define (state+literal state) (cond ((fx<=? state state.short-repeat->literal->literal) ;; X->literal->literal becomes literal->literal. state.literal->literal) ((fx<=? state state.literal->short-repeat) ;; literal->X becomes X->literal. (fx- state (fx- state.literal->short-repeat state.short-repeat->literal))) (else ;; non-literal->X becomes X->literal. (fx- state (fx- state.non-literal->repeat state.repeat->literal))))) (define (state+short-repeat state) (if (literal-state? state) state.literal->short-repeat state.non-literal->repeat)) (define (state+long-repeat state) (if (literal-state? state) state.literal->long-repeat state.non-literal->repeat)) (define (state+match state) (if (literal-state? state) state.literal->match state.non-literal->match)) ;; For the encoding of lengths (define minimum-match-length 2) (define length-bits-low 3) ;bit-widths (define length-bits-middle 3) (define length-bits-high 8) (define maximum-position-bits 4) ;maximum for `pb' (define length.choice 0) ;offsets into length coders: (define length.choice-2 (+ length.choice 1)) (define length.low (+ length.choice-2 1)) (define length.middle (+ length.low (expt 2 (+ maximum-position-bits length-bits-low)))) (define length.high (+ length.middle (expt 2 (+ maximum-position-bits length-bits-middle)))) (define length-coder-size (+ length.high (expt 2 length-bits-high))) (define (decode-length decoder position-state) ;; Decodes a length. They are encoded (and returned) with ;; minimum-match-length subtracted. First there's a prefix code ;; that determines a base and then either 3 or 8 bits follow. (trace \";; decoding a match length...\") (cond ((rc-zero? decoder length.choice) ;; base = 0. length in [min+base+0,min+base+7] = [2,9]. (rc-bit-tree-decode decoder (fx+ length.low (fxasl position-state length-bits-low)) length-bits-low)) (else (cond ((rc-zero? decoder length.choice-2) ;; base = 8. length in [min+base+0,min+base+7] = [10,17]. (fx+ (expt 2 length-bits-low) (rc-bit-tree-decode decoder (fx+ length.middle (fxasl position-state length-bits-middle)) length-bits-middle))) (else ;; base = 16. length in [min+base+0,min+base+255] = [18,273]. (fx+ (fx+ (expt 2 length-bits-low) (expt 2 length-bits-middle)) (rc-bit-tree-decode decoder length.high length-bits-high))))))) ;; For the encoding of distances (define start-pos-model-index 4) (define end-pos-model-index 14) (define full-distances (expt 2 (/ end-pos-model-index 2))) (define length-to-position-states 4) (define distance-bits-pos-slot 6) (define distance-bits-alignment 4) ;the lowest bits (define (decode-distance pos-slot-decoders pos-decoders alignment-decoders len) ;; Decodes a distance. They are encoded with 1 subtracted (at ;; least from the perspective of the sliding-buffer library). (define (get-bits decoder base bits distance) (let lp ((n 0) (symbol 1) (bits bits) (distance distance)) (if (fxzero? bits) (+ distance 1) (let-values (((bit symbol) (rc-get-bit* decoder (+ base symbol) symbol))) (if (fxzero? bit) (lp (fx+ n 1) symbol (fx- bits 1) distance) (lp (fx+ n 1) symbol (fx- bits 1) (bitwise-ior distance (asl 1 n)))))))) (trace \";; decoding a match distance...\") (let ((pos-slot (rc-bit-tree-decode pos-slot-decoders ;; Different probabilities are ;; used for small lengths. (fxasl (fxmin len (- length-to-position-states 1)) distance-bits-pos-slot) distance-bits-pos-slot))) (trace \"pos-slot: \" pos-slot) (cond ((fx? byte #xff) (fxand byte #xff)))) (if (not match-byte) (get-byte 1) (let lp ((match-byte match-byte) (byte 1)) (if (fx>? byte #xff) (get-byte byte) ;; TODO: describe the three parts of the subcoder (let* ((match-byte* (fxasl match-byte 1)) (match-bit (fxand match-byte* #x100))) (let-values (((bit byte*) (rc-get-bit* decoders (+ subcoder #x100 match-bit byte) byte))) (if (fx=? (fxasr match-bit 8) bit) (lp match-byte* byte*) (get-byte byte*)))))))) ;; Probability vectors for the range coding (let ((match-decoders (make-bit-model (* number-of-states (expt 2 maximum-position-bits)))) (rep-decoders (make-bit-model number-of-states)) (rep-G0-decoders (make-bit-model number-of-states)) (rep-G1-decoders (make-bit-model number-of-states)) (rep-G2-decoders (make-bit-model number-of-states)) (rep-0-long-decoders (make-bit-model (* number-of-states (expt 2 maximum-position-bits)))) (literal-decoders (make-bit-model (asl literal-coder-size #;4 (+ lc lp)))) (pos-decoders (make-bit-model (- full-distances end-pos-model-index))) (pos-slot-decoders (make-bit-model (* length-to-position-states (expt 2 distance-bits-pos-slot)))) (alignment-decoders (make-bit-model (expt 2 distance-bits-alignment))) (len-decoders (make-bit-model length-coder-size)) (rep-len-decoders (make-bit-model length-coder-size))) (define (get-length/distance position-state state rep0 rep1 rep2 rep3) ;; Reads a length and distance code. If the code includes length ;; or distance, they are returned. If the corresponding value is ;; #f it must be decoded separately. Also returns the new state. (if (rc-zero? rep-decoders state) (values #f #f len-decoders (state+match state) rep0 rep1 rep2) (if (rc-zero? rep-G0-decoders state) (if (rc-zero? rep-0-long-decoders (+ (asl state maximum-position-bits) position-state)) (values (- 1 minimum-match-length) rep0 rep-len-decoders (state+short-repeat state) rep1 rep2 rep3) (values #f rep0 rep-len-decoders (state+long-repeat state) rep1 rep2 rep3)) (if (rc-zero? rep-G1-decoders state) (values #f rep1 rep-len-decoders (state+long-repeat state) rep0 rep2 rep3) (if (rc-zero? rep-G2-decoders state) (values #f rep2 rep-len-decoders (state+long-repeat state) rep0 rep1 rep3) (values #f rep3 rep-len-decoders (state+long-repeat state) rep0 rep1 rep2)))))) (let restart ((dictionary dictionary) (usize usize) (lc lc) (lp lp) (pb pb) (position position) (state state.literal->literal) (rep0 1) (rep1 1) (rep2 1) (rep3 1)) (rc-reset) (let ((position-state-mask (- (asl 1 pb) 1)) (literal-pos-mask (- (asl 1 lp) 1))) ;; Decoder loop (let loop ((position position) (chunk-position 0) (state state) (rep0 rep0) (rep1 rep1) (rep2 rep2) (rep3 rep3)) (cond ((fx>=? chunk-position usize) ;; Return the full state so that it can be restored ;; later. Used by LZMA2 in which a \"block\" is multiple ;; LZMA chunks. (rc-normalize) (letrec ((restart-lzma (lambda (dictionary usize lc lp pb) (restart dictionary usize lc lp pb position state rep0 rep1 rep2 rep3)))) restart-lzma)) (else (let ((position-state (bitwise-and position position-state-mask))) (trace \"position = \" position \" position-state = \" position-state) (trace \"state: \" (list state rep0 rep1 rep2 rep3)) (trace \"chunk-position = \" chunk-position) (cond ((rc-zero? match-decoders (fx+ position-state (fxasl state maximum-position-bits))) (trace \";;; LITERAL\") (let* ((previous-byte (if (positive? position) (sliding-buffer-lookback-u8 dictionary 1) 0)) (subcoder (* (+ (asl (bitwise-and position literal-pos-mask) lc) (asr previous-byte (fx- 8 lc))) literal-coder-size)) (match-byte (and (not (literal-state? state)) (sliding-buffer-lookback-u8 dictionary rep0))) (literal (decode-literal literal-decoders subcoder match-byte))) (trace \"#;literal: \" literal) (sliding-buffer-put-u8! dictionary literal)) (loop (+ position 1) (fx+ chunk-position 1) (state+literal state) rep0 rep1 rep2 rep3)) (else (trace \";;; MATCH\") (let-values (((len distance length-decoder state rep1 rep2 rep3) (get-length/distance position-state state rep0 rep1 rep2 rep3))) (let* ((len (or len (decode-length length-decoder position-state))) (dist (or distance (decode-distance pos-slot-decoders pos-decoders alignment-decoders len)))) ;; XXX: the distance can encode end-of-stream in ;; old LZMA. (let ((len (+ len minimum-match-length))) (trace \"#;copy: distance=\" dist \" len=\" len) (sliding-buffer-dup! dictionary dist len) (loop (+ position len) (fx+ chunk-position len) state dist rep1 rep2 rep3))))))))))))))) ") ("bootar/compression/lzma2.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2011, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; Decoder for LZMA2, a layer above LZMA. #| A chunk can be at most this large when uncompressed: (let ((usize* #xFFFF) (ctrl #xFF)) (fx+ (fxior usize* (fxarithmetic-shift-left (fxbit-field ctrl 0 5) 16)) 1)) => 2097152 |# (library (compression lzma2) (export lzma2-decode-chunk) (import (rnrs) (compression lzma) (compression sliding-buffer) (struct pack)) (define-syntax trace (syntax-rules () #; ((_ . args) (begin (for-each display (list . args)) (newline))) ((_ . args) (begin 'dummy)))) ;; Decodes one LZMA2 chunk. Returns a new state. If there's no more ;; data in the LZMA2 block then the end-of-file object is returnred. (define (lzma2-decode-chunk p sink dictionary-size state) (define who 'lzma2-decode-chunk) (define fxasl fxarithmetic-shift-left) (define (decode-props b) (let* ((pb (fxdiv b (* 9 5))) (prop (fx- b (fx* pb (* 9 5)))) (lp (fxdiv prop 9)) (lc (fx- prop (fx* lp 9)))) (trace \"LZMA2: Literal context bits (lc): \" lc ;[0,8] \", Literal position bits (lp): \" lp ;[0,4] \", Position bits (pb): \" pb) ;[0,4] (values lc lp pb))) (define (get-props p) (trace \"LZMA2: reading new properties\") (let ((b (get-u8 p))) (when (fx>? b (+ (* (+ (* 4 5) 4) 9) 8)) (error who \"Bad properties for LZMA2 chunk\" p)) b)) (define (fresh-dictionary) (trace \"LZMA2: dictionary reset\") (make-sliding-buffer sink dictionary-size)) (define (return-state dictionary props lzma-state position) (vector dictionary props lzma-state position)) (define (empty-state) (vector #f #f #f 0)) (let ((state (or state (empty-state)))) (let ((dictionary (vector-ref state 0)) (props (vector-ref state 1)) (lzma-state (vector-ref state 2)) (position (vector-ref state 3))) (let ((ctrl (get-u8 p))) (trace \"LZMA2 control: #x\" (number->string ctrl 16)) (case ctrl ((#x00) (eof-object)) ;end of block ((#x01 #x02) ;uncompressed chunk (let ((dictionary (if (= ctrl #x01) (fresh-dictionary) dictionary))) (let ((csize (fx+ (get-unpack p \"!S\") 1))) (trace \"Uncompressed chunk: \" csize) (sliding-buffer-read! dictionary p csize) (sliding-buffer-drain! dictionary) (return-state dictionary props lzma-state (+ position csize))))) (else (let-values (((usize* csize*) (get-unpack p \"!SS\"))) (let ((usize (fx+ (fxior usize* (fxasl (fxbit-field ctrl 0 5) 16)) 1)) (csize (fx+ csize* 1)) (cmd (fxand ctrl #xE0))) (trace \"Uncompressed size: \" usize \" Compressed size: \" csize) ;; The control codes are instructions to reset the ;; dictionary, to read new properties, or to reset ;; the decoder state. (case cmd ((#x80 #xA0 #xC0 #xE0) (let ((dictionary (if (memv cmd '(#xE0)) (fresh-dictionary) dictionary)) (props (if (memv cmd '(#xC0 #xE0)) (get-props p) props))) (let*-values (((lc lp pb) (decode-props props))) (let ((lzma-state* (cond ((and lzma-state (not (memv cmd '(#xA0 #xC0 #xE0)))) (trace \"LZMA: reuse old decoder state\") (lzma-state dictionary usize lc lp pb)) (else (trace \"LZMA2: reset decoder state\") (lzma-decode-chunk p dictionary usize lc lp pb position))))) (trace \"LZMA2: chunk decoded\") (sliding-buffer-drain! dictionary) (return-state dictionary props lzma-state* (+ position usize)))))) (else (error who \"Invalid control code\" ctrl)))))))))))) ") ("bootar/compression/xz.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2011, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; This library reads Lasse Collin and Igor Pavlov's .xz file format. ;; http://tukaani.org/xz/format.html (library (compression xz) (export make-xz-input-port open-xz-file-input-port #;extract-xz is-xz-file?) (import (rnrs) (compression lzma2) (hashing crc) (hashing sha-2) ;for streams (struct pack)) (define-syntax trace (syntax-rules () #; ((_ . args) (begin (for-each display (list . args)) (newline))) ((_ . args) (begin 'dummy)))) (define-crc crc-32) ;for headers etc (define xz-magic #vu8(#xFD #x37 #x7A #x58 #x5A #x00)) (define xz-filter-delta #x03) (define xz-filter-bcj-x86 #x04) (define xz-filter-bcj-powerpc #x05) (define xz-filter-bcj-itanium #x06) (define xz-filter-bcj-armel #x07) (define xz-filter-bcj-armel-thumb #x08) (define xz-filter-bcj-sparc #x09) (define xz-filter-lzma2 #x21) (define (checksum-procedures algorithm) ;; Takes a name and returns init, update and finish. (case algorithm ((crc-32) (values crc-32-init crc-32-update (lambda (checksum) (pack \"bytevector checksum)))) (else ;; Unknown or \"none\" algorithm. (values (lambda () #f) (lambda x #f) (lambda x #f))))) (define (is-xz-file? f) (let* ((f (if (input-port? f) f (open-file-input-port f))) (pos (port-position f))) (set-port-position! f 0) (let ((bv (get-bytevector-n f (bytevector-length xz-magic)))) (set-port-position! f pos) (equal? bv xz-magic)))) (define (get-varint p max-bytes who) (let ((max (* (if max-bytes (min 9 max-bytes) 9) 7))) (let lp ((ret 0) (shift 0)) (if (= shift max) ret (let ((b (get-u8 p))) (cond ((eof-object? b) (error who \"Unexpected end-of-file in variable length integer\" p)) ((zero? b) ret) (else (let ((ret* (bitwise-ior ret (bitwise-arithmetic-shift-left (fxand b #x7f) shift)))) (if (fx<=? b #x7f) ret* (lp ret* (+ shift 7))))))))))) (define (get-stream-header p) (define who 'get-stream-header) (define len #vu8(0 4 4 4 8 8 8 16 16 16 32 32 32 64 64 64)) (define crc '#(none crc-32 #f #f crc-64/ecma-182 #f #f #f #f #f sha-256 #f #f #f #f #f)) (unless (equal? (get-bytevector-n p (bytevector-length xz-magic)) xz-magic) (error who \"Expected to find an XZ stream header\" p)) (let-values (((fnull flags) (get-unpack p \"CC\"))) (let ((algorithm (fxbit-field flags 0 4)) (reserved (fxbit-field flags 4 8))) (let ((have (crc-32 (pack \"CC\" fnull flags))) (want (get-unpack p \" bits 40) (error who \"The block header specifies an overlarge LZMA2 dictionary\" in bits)) ((= bits 40) #xFFFFFFFF) (else (let* ((b (fxior #b10 (fxand bits #b1))) (size (bitwise-arithmetic-shift-left b (+ (fxdiv bits 2) 11)))) (trace \"LZMA2 dictionary size: \" size) size)))))) ;; TODO: the XZ format supports seeking, so port-position and ;; set-port-position! could be implemented. TODO: concatenated ;; streams. TODO: the conditions here should probably be I/O ;; related. (define who 'make-xz-input-port) (let*-values (((check-length check-algorithm) (get-stream-header in)) ((check-init check-update! check-finish!) (checksum-procedures check-algorithm))) (trace \"XZ check algorithm: \" check-algorithm) (let ((buffer (make-bytevector (expt 2 15))) ;block buffer (buf-r 0) (buf-w 0)) (define checksum (check-init)) (define block-start #f) (define lzma2-dictsize) (define lzma2-state #f) (define (grow! minimum) ;; LZMA chunks can be at most 2MiB when uncompressed. (when (fx \" have) (when (and have (not (equal? want have))) (error who \"There has been an LZMA2 block checksum mismatch.\" want have)))))) (define (read! bytevector start count) ;; Read up to `count' bytes from the source, write them to ;; `bytevector' at index `start'. Return the number of bytes ;; read (zero means end of file). (let loop () (when (zero? buf-w) ;buffer is empty? (trace \"XZ input port: needs more data\") (cond ((not block-start) ;; Start reading a new block if one is available (when (next-block) (next-chunk))) (else (next-chunk) (when (not block-start) ;; This chunk ended the block. (loop)))))) ;; Return data from the block buffer. (let* ((valid (- buf-w buf-r)) (returned (min count valid))) (bytevector-copy! buffer buf-r bytevector start returned) (cond ((= returned valid) ;; The buffer is now empty. (set! buf-r 0) (set! buf-w 0)) (else (set! buf-r (+ buf-r returned)))) returned)) (define (close) (trace \"XZ input port closed\") (when checksum ;; Read to the end of the input so that the checksum is verified. (let lp () (set! buf-r 0) (set! buf-w 0) (unless (zero? (read! buffer 0 (bytevector-length buffer))) (lp)))) (set! buffer #f) (when close-underlying-port? (close-port in)) (set! in #f)) (make-custom-binary-input-port id read! #f #f close)))) (define (open-xz-file-input-port filename) (make-xz-input-port (open-file-input-port filename) (string-append \"xz \" filename) 'close)) ;; TODO: extract-xz? ) ") ("bootar/compression/bzip2.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2020 Timothy Sample ;; Parts of this file were copied from 'xz.scm', which has the ;; following copyright notice: ;; Copyright © 2011, 2012, 2017 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;; This library reads Julian Seward's BZip2 file format. The format ;; has no official specification, but there is a very thorough ;; description of it in the \"github.com/dsnet/compress\" Go library: ;; https://github.com/dsnet/compress/blob/master/doc/bzip2-format.pdf (library (compression bzip2) (export make-bzip2-input-port open-bzip2-file-input-port is-bzip2-file?) (import (rnrs (6)) (compression bitstream) (compression huffman)) ;; Guile -> R6RS compatibility. It would be better to remove these ;; definitions and use idiomatic R6RS. (define (1+ x) (+ x 1)) (define (1- x) (- x 1)) (define reverse! reverse) ;; This is needed because we used the wrong type for the symbol map. ;; The reader should just output a bytevector directly. (define (u8-list->btevector xs) (let ((count (length xs)) (bv (make-bytevector count))) (let lp ((k 0) (xs xs)) (unless (null? xs) (bytevector-u8-set! bv k (car xs)) (lp (+ k 1) (cdr xs)))) bv)) (define bzip2-magic #vu8(#x42 #x5a #x68)) (define bzip2-block-magic #vu8(#x31 #x41 #x59 #x26 #x53 #x59)) (define bzip2-footer-magic #vu8(#x17 #x72 #x45 #x38 #x50 #x90)) (define (is-bzip2-file? f) (let* ((f (if (input-port? f) f (open-file-input-port f))) (pos (port-position f))) (set-port-position! f 0) (let ((bv (get-bytevector-n f 3))) (set-port-position! f pos) (equal? bv bzip2-magic)))) (define (get-stream-header p) (define who 'get-stream-header) (unless (equal? (get-bytevector-n p (bytevector-length bzip2-magic)) bzip2-magic) (error who \"Expected to find an BZip2 stream header\" p)) (let ((level (bytevector-u8-ref (get-bytevector-n p 1) 0))) (unless (and (> level #x31) (<= level #x39)) (error who \"Bad level value in BZip2 stream header\" p)) (* 100000 (- level #x30)))) (define (is-stream-footer? br) (= (lookahead-bits br 8) (bytevector-u8-ref bzip2-footer-magic 0))) (define-record-type block-metadata (fields crc randomized? origin-pointer symbol-map selectors trees)) ;; TODO: Do this with eager popcounts and vectors? (define (get-symbol-map br) \"Read a symbol map from the bitreader BR. A symbol map is a list of symbols used for inverting the move-to-front transform performed on the block data.\" (let ((level-bits (get-bits br 16))) (let lp1 ((i1 0) (acc1 '())) (cond ((> i1 15) (reverse! acc1)) ((fxbit-set? level-bits (- 15 i1)) (let ((symbol-bits (get-bits br 16))) (let lp2 ((i2 0) (acc2 acc1)) (cond ((> i2 15) (lp1 (1+ i1) acc2)) ((fxbit-set? symbol-bits (- 15 i2)) (lp2 (1+ i2) (cons (+ (* i1 16) i2) acc2))) (else (lp2 (1+ i2) acc2)))))) (else (lp1 (1+ i1) acc1)))))) (define (get-selectors br selector-count tree-count) \"Read SELECTOR-COUNT selectors from the bitreader BR, decoding them using TREE-COUNT. Each selector cooresponds to a chunk of 50 encoded symbols, and determines which tree to use to decode the chunk.\" ;; This bytevector holds the tree indexes for the inverse ;; move-to-front transform. (define tree-stack (make-bytevector tree-count)) ;; This bytevector will hold the intermediate indexes and the ;; output. (define output (make-bytevector selector-count)) ;; Read the selector indexes. (do ((k 0 (1+ k))) ((>= k selector-count)) (let ((index (do ((x 0 (1+ x))) ((= 0 (get-bits br 1)) x)))) (bytevector-u8-set! output k index))) ;; Initialize 'tree-stack'. (do ((k 0 (1+ k))) ((>= k tree-count)) (bytevector-u8-set! tree-stack k k)) ;; Perform an inverse move-to-front transform on 'output' using ;; 'tree-stack'. (do ((k 0 (1+ k))) ((>= k selector-count) output) (let* ((index (bytevector-u8-ref output k)) (x (bytevector-u8-ref tree-stack index))) (bytevector-copy! tree-stack 0 tree-stack 1 index) (bytevector-u8-set! tree-stack 0 x) (bytevector-u8-set! output k x)))) (define (get-delta br) \"Read a code size delta from the bitreader BR.\" ;; We start the delta at 0 and then read a sequence of increment and ;; decrement instructions. Increment is encoded as '10', decrement ;; is encoded as '11', and '0' marks the end of the delta. (let lp ((b (get-bits br 1)) (delta 0)) (if (= b 1) (if (= (get-bits br 1) 1) (lp (get-bits br 1) (1- delta)) (lp (get-bits br 1) (1+ delta))) delta))) (define (get-tree br symbol-count) \"Read a canonical Huffman tree with SYMBOL-COUNT symbols from the bitreader BR. The result is ready to be passed to the 'reconstruct-codes' procedure.\" ;; The list of symbol lengths are encoded as a initial length ;; followed by a sequence of deltas. (let lp ((i 0) (previous-size (get-bits br 5)) (acc '())) (if (>= i symbol-count) (reverse! acc) (let* ((delta (get-delta br)) (size (+ previous-size delta))) (lp (1+ i) size (cons (cons i size) acc)))))) (define (get-trees br tree-count symbol-count) \"Read TREE-COUNT canonical Huffman trees from BR, each having SYMBOL-COUNT symbols.\" (define trees (make-vector tree-count)) (do ((k 0 (1+ k))) ((>= k tree-count) trees) (vector-set! trees k (get-tree br symbol-count)))) (define (get-block-metadata br) (define who 'get-block-header) ;; Check the magic number. (do ((k 0 (1+ k))) ((>= k (bytevector-length bzip2-block-magic))) (unless (= (get-bits br 8) (bytevector-u8-ref bzip2-block-magic k)) (error who \"Expected to find an BZip2 block header\" br))) ;; TODO: Check CRC and ensure 'randomized?' is false. (let* ((crc-high (get-bits br 16)) (crc-low (get-bits br 16)) (crc (+ (* crc-high #x10000) crc-low)) (randomized? (= (get-bits br 1) 1)) (origin-pointer (get-bits br 24)) (symbol-map (get-symbol-map br)) (tree-count (get-bits br 3)) (selector-count (get-bits br 15)) (selectors (get-selectors br selector-count tree-count)) (trees (get-trees br tree-count (+ 2 (length symbol-map))))) (make-block-metadata crc randomized? origin-pointer symbol-map selectors trees))) (define (get-raw-block-generator br selectors trees) (define tables (vector-map (lambda (tree) (let ((codes (reconstruct-codes < tree))) (canonical-codes->big-endian-lookup-table codes))) trees)) (let ((selector-index 0) (chunk-index 0) (zero-count 0) (next-value #f)) (lambda () (let* ((selector (bytevector-u8-ref selectors selector-index)) (table (vector-ref tables selector)) (code (get-next-code br table))) (set! chunk-index (1+ chunk-index)) (when (>= chunk-index 50) ; XXX: Name this constant! (set! chunk-index 0) (set! selector-index (1+ selector-index))) code)))) (define (get-block-generator br selectors trees) (let ((gen (get-raw-block-generator br selectors trees)) (zero-count 0) (next-value #f)) (lambda () (cond ((> zero-count 0) (set! zero-count (1- zero-count)) 0) (next-value (let ((value next-value)) (set! next-value #f) value)) (else (let lp ((value (gen)) (count 0) (acc 0)) (cond ((or (= value 0) (= value 1)) (lp (gen) (1+ count) (fxior (fxarithmetic-shift-left value count) acc))) ((> count 0) (set! zero-count (- (fxior (fxarithmetic-shift-left 1 count) acc) 2)) (set! next-value (1- value)) 0) (else (1- value))))))))) \f ;; Burrows-Wheeler transform (define (decode-mtf+bw! gen symbol-map origin-pointer) ;; The length of SYMBOL-MAP represents the smallest positive number ;; that is not an index into SYMBOL-MAP. This value is used to mark ;; the end of the block. (define end-of-block (bytevector-length symbol-map)) ;; This bytevector will hold the cumulative counts of each byte ;; (symbol in our alphabet). The last element represents the total ;; number of bytes. (define cumulative-counts (make-vector 257 0)) ;; This will hold the output of the inverse move-to-front transform, ;; which will be the input of the inverse Burrows-Wheeler transform. (define scrambled (make-bytevector 900000)) ;; This will hold a list of indexes into 'scrambled' (in the ;; intended order). (define ordered (make-vector 900000)) ;; The output buffer. (define output (make-bytevector (* 259 (/ 900000 5)))) ;; Decode the move-to-front transform, and at the same time, fill ;; 'prefix-counts' and put non-cumulative counts in ;; 'cumulative-counts'. (do ((k 0 (1+ k)) (index (gen) (gen))) ((= index end-of-block)) (let* ((symbol (bytevector-u8-ref symbol-map index)) (count (vector-ref cumulative-counts symbol))) (bytevector-copy! symbol-map 0 symbol-map 1 index) (bytevector-u8-set! symbol-map 0 symbol) (bytevector-u8-set! scrambled k symbol) (vector-set! cumulative-counts symbol (1+ count)))) ;; Make the counts in 'cumulative-counts' cumulative. (let lp ((k 0) (sum 0)) (when (< k 257) (let* ((count (vector-ref cumulative-counts k))) (vector-set! cumulative-counts k sum) (lp (1+ k) (+ sum count))))) ;; Compute the 'ordered' vector. (do ((k 0 (1+ k))) ((>= k (vector-ref cumulative-counts 256))) (let* ((symbol (bytevector-u8-ref scrambled k)) (count (vector-ref cumulative-counts symbol))) (vector-set! ordered count k) (vector-set! cumulative-counts symbol (1+ count)))) (let lp ((loop-count 0) (k 0) (pointer (vector-ref ordered origin-pointer)) (last-symbol -1) (repeat-count 0)) (if (>= loop-count (vector-ref cumulative-counts 256)) (let ((bv (make-bytevector k))) (bytevector-copy! output 0 bv 0 k) bv) (let ((symbol (bytevector-u8-ref scrambled pointer))) (cond ((= repeat-count 3) (do ((j 0 (1+ j))) ((>= j symbol)) (bytevector-u8-set! output (+ k j) last-symbol)) (lp (1+ loop-count) (+ k symbol) (vector-ref ordered pointer) -1 0)) (else (bytevector-u8-set! output k symbol) (lp (1+ loop-count) (1+ k) (vector-ref ordered pointer) symbol (if (= symbol last-symbol) (1+ repeat-count) 0)))))))) (define (get-block br) (let* ((metadata (get-block-metadata br)) (selectors (block-metadata-selectors metadata)) (trees (block-metadata-trees metadata)) (gen (get-block-generator br selectors trees)) (symbol-map (u8-list->bytevector (block-metadata-symbol-map metadata))) (origin-pointer (block-metadata-origin-pointer metadata))) (decode-mtf+bw! gen symbol-map origin-pointer))) (define (make-bzip2-input-port in id close-underlying-port?) (define level (get-stream-header in)) (define br (make-bzip2-bit-reader in)) (define block #f) (define block-index 0) (define block-count 0) (define (read! bv start count) (when (= block-index block-count) (unless (is-stream-footer? br) (set! block (get-block br)) (set! block-count (bytevector-length block)) (set! block-index 0))) (let* ((valid (- block-count block-index)) (returned (min count valid))) (bytevector-copy! block block-index bv start returned) (set! block-index (+ block-index returned)) returned)) (define (close) (set! block #f) (when close-underlying-port? (close-port in)) (set! in #f)) (make-custom-binary-input-port id read! #f #f close)) (define (open-bzip2-file-input-port filename) (make-bzip2-input-port (open-file-input-port filename) (string-append \"bzip2 \" filename) 'close))) ") ("bootar/struct") ("bootar/struct/pack.scm" . ";; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2008, 2009, 2010, 2011, 2012, 2017, 2019 Göran Weinholt ;; SPDX-License-Identifier: MIT ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the \"Software\"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. #!r6rs ;;; Syntax for packing and unpacking C structs using bytevectors (library (struct pack) (export format-size pack pack! unpack get-unpack put-pack) (import (rnrs (6))) (define (roundb offset alignment) (bitwise-and (+ offset (- alignment 1)) (- alignment))) (define-syntax unpack* (lambda (x) (define (type c) (case c ((#\\c) (values #'(lambda (bv idx _e) (bytevector-s8-ref bv idx)) #'bytevector-s8-ref 1)) ((#\\C) (values #'(lambda (bv idx _e) (bytevector-u8-ref bv idx)) #'bytevector-u8-ref 1)) ((#\\s) (values #'bytevector-s16-ref #'bytevector-s16-native-ref 2)) ((#\\S) (values #'bytevector-u16-ref #'bytevector-u16-native-ref 2)) ((#\\l) (values #'bytevector-s32-ref #'bytevector-s32-native-ref 4)) ((#\\L) (values #'bytevector-u32-ref #'bytevector-u32-native-ref 4)) ((#\\q) (values #'bytevector-s64-ref #'bytevector-s64-native-ref 8)) ((#\\Q) (values #'bytevector-u64-ref #'bytevector-u64-native-ref 8)) ((#\\f) (values #'bytevector-ieee-single-ref #'bytevector-ieee-single-native-ref 4)) ((#\\d) (values #'bytevector-ieee-double-ref #'bytevector-ieee-double-native-ref 8)) (else (syntax-violation 'unpack \"Bad character in format string\" x c)))) (define (roundb offset alignment) (bitwise-and (+ offset (- alignment 1)) (- alignment))) (syntax-case x () ((_ fmt bytevector) #'(unpack* fmt bytevector 0)) ((_ fmt* bytevector base-offset*) (with-syntax ([(refs ...) (let ((fmt (syntax->datum #'fmt*))) (let lp ((i 0) (o 0) (rep #f) (endian #f) (align #t) (refs '())) (cond ((= i (string-length fmt)) (reverse refs)) ((char-whitespace? (string-ref fmt i)) (lp (+ i 1) o rep endian align refs)) (else (case (string-ref fmt i) ((#\\0 #\\1 #\\2 #\\3 #\\4 #\\5 #\\6 #\\7 #\\8 #\\9) (lp (+ i 1) o (+ (- (char->integer (string-ref fmt i)) (char->integer #\\0)) (* (if rep rep 0) 10)) endian align refs)) ((#\\=) (lp (+ i 1) o #f #f align refs)) ((#\\<) (lp (+ i 1) o #f #'(endianness little) align refs)) ((#\\> #\\!) (lp (+ i 1) o #f #'(endianness big) align refs)) ((#\\x) (lp (+ i 1) (+ o (or rep 1)) #f endian align refs)) ((#\\a) (lp (+ i 1) o #f endian #t refs)) ((#\\u) (lp (+ i 1) o #f endian #f refs)) (else (let-values ([(ref nref n) (type (string-ref fmt i))]) (let ((o (if align (roundb o n) o)) (rep (or rep 1))) (lp (+ i 1) (+ o (* n rep)) #f endian align (let lp* ((o o) (rep rep) (refs refs)) (if (eqv? rep 0) refs (lp* (+ o n) (- rep 1) (cons (cond [endian #`(#,ref bv (fx+ base-offset #,o) #,endian)] [(or (not align) (not (and (integer? (syntax->datum #'base-offset*)) (eqv? 0 (mod (syntax->datum #'base-offset*) n))))) #`(#,ref bv (fx+ base-offset #,o) (native-endianness))] [else #`(#,nref bv (fx+ base-offset #,o))]) refs)))))))))))))]) #'(let ([bv bytevector] [base-offset base-offset*]) (values refs ...))))))) (define unpack** (case-lambda ((fmt bv offset) (define (type c) (case c ((#\\c) (values (lambda (bv idx _e) (bytevector-s8-ref bv idx)) 1)) ((#\\C) (values (lambda (bv idx _e) (bytevector-u8-ref bv idx)) 1)) ((#\\s) (values bytevector-s16-ref 2)) ((#\\S) (values bytevector-u16-ref 2)) ((#\\l) (values bytevector-s32-ref 4)) ((#\\L) (values bytevector-u32-ref 4)) ((#\\q) (values bytevector-s64-ref 8)) ((#\\Q) (values bytevector-u64-ref 8)) ((#\\f) (values bytevector-ieee-single-ref 4)) ((#\\d) (values bytevector-ieee-double-ref 8)) (else (error 'unpack \"Bad character in format string\" fmt c)))) (let lp ((i 0) (o offset) (rep #f) (endian #f) (align #t) (refs '())) (cond ((fx=? i (string-length fmt)) (apply values (reverse refs))) ((char-whitespace? (string-ref fmt i)) (lp (fx+ i 1) o rep endian align refs)) (else (case (string-ref fmt i) ((#\\0 #\\1 #\\2 #\\3 #\\4 #\\5 #\\6 #\\7 #\\8 #\\9) (lp (fx+ i 1) o (fx+ (fx- (char->integer (string-ref fmt i)) (char->integer #\\0)) (fx* (if rep rep 0) 10)) endian align refs)) ((#\\=) (lp (fx+ i 1) o #f #f align refs)) ((#\\<) (lp (fx+ i 1) o #f (endianness little) align refs)) ((#\\> #\\!) (lp (fx+ i 1) o #f (endianness big) align refs)) ((#\\x) (lp (fx+ i 1) (fx+ o (or rep 1)) #f endian align refs)) ((#\\a) (lp (fx+ i 1) o #f endian #t refs)) ((#\\u) (lp (fx+ i 1) o #f endian #f refs)) (else (let-values (((ref n) (type (string-ref fmt i)))) (let ((o (if align (roundb o n) o)) (rep (or rep 1))) (lp (fx+ i 1) (fx+ o (fx* n rep)) #f endian align (let lp* ((o o) (rep rep) (refs refs)) (if (eqv? rep 0) refs (lp* (fx+ o n) (fx- rep 1) (cons (cond ((eq? ref 's8) (bytevector-s8-ref bv (fx+ offset o))) ((eq? ref 'u8) (bytevector-u8-ref bv (fx+ offset o))) (endian (ref bv (fx+ offset o) endian)) (else (ref bv (fx+ offset o) (native-endianness)))) refs))))))))))))) ((fmt bv) (unpack** fmt bv 0)))) ;; Use the unpack* expander if possible, otherwise use the unpack** ;; function. (define-syntax unpack (make-variable-transformer (lambda (x) (syntax-case x () ((_ fmt bytevector) #'(unpack fmt bytevector 0)) ((_ fmt bytevector offset) (string? (syntax->datum #'fmt)) #'(unpack* fmt bytevector offset)) ((_ . rest) #'(unpack** . rest)) (_ #'unpack**))))) ;; Find the number of bytes the format requires. ;; (format-size \"2SQ\") => 16 (define (format-size* fmt) (define (size c) (case c ((#\\x #\\c #\\C) 1) ((#\\s #\\S) 2) ((#\\l #\\L #\\f) 4) ((#\\q #\\Q #\\d) 8) (else (error 'format-size \"Bad character in format string\" fmt c)))) (let lp ((i 0) (s 0) (rep #f) (align #t)) (cond ((= i (string-length fmt)) s) ((char<=? #\\0 (string-ref fmt i) #\\9) (lp (+ i 1) s (+ (- (char->integer (string-ref fmt i)) (char->integer #\\0)) (* (if rep rep 0) 10)) align)) ((char-whitespace? (string-ref fmt i)) (lp (+ i 1) s rep align)) ((eqv? (string-ref fmt i) #\\a) (lp (+ i 1) s rep #t)) ((eqv? (string-ref fmt i) #\\u) (lp (+ i 1) s rep #f)) ((memv (string-ref fmt i) '(#\\@ #\\= #\\< #\\> #\\!)) (lp (+ i 1) s #f align)) (else (let ((n (size (string-ref fmt i)))) (lp (+ i 1) (+ (if align (roundb s n) s) (if rep (* n rep) n)) #f align)))))) (define-syntax format-size (make-variable-transformer (lambda (x) (syntax-case x () ((_ fmt-stx) (string? (syntax->datum #'fmt-stx)) (let () (define (roundb offset alignment) (bitwise-and (+ offset (- alignment 1)) (- alignment))) (define (format-size fmt) (define (size c) (case c ((#\\x #\\c #\\C) 1) ((#\\s #\\S) 2) ((#\\l #\\L #\\f) 4) ((#\\q #\\Q #\\d) 8) (else (syntax-violation 'format-size \"Bad character in format string\" #'fmt-stx c)))) (let lp ((i 0) (s 0) (rep #f) (align #t)) (cond ((= i (string-length fmt)) s) ((char<=? #\\0 (string-ref fmt i) #\\9) (lp (+ i 1) s (+ (- (char->integer (string-ref fmt i)) (char->integer #\\0)) (* (if rep rep 0) 10)) align)) ((char-whitespace? (string-ref fmt i)) (lp (+ i 1) s rep align)) ((eqv? (string-ref fmt i) #\\a) (lp (+ i 1) s rep #t)) ((eqv? (string-ref fmt i) #\\u) (lp (+ i 1) s rep #f)) ((memv (string-ref fmt i) '(#\\@ #\\= #\\< #\\> #\\!)) (lp (+ i 1) s #f align)) (else (let ((n (size (string-ref fmt i)))) (lp (+ i 1) (+ (if align (roundb s n) s) (if rep (* n rep) n)) #f align)))))) (format-size (syntax->datum #'fmt-stx)))) ((_ fmt) #'(format-size* fmt)))))) (define (get-unpack** port fmt) (unpack fmt (get-bytevector-n port (format-size* fmt)))) (define-syntax get-unpack (make-variable-transformer (lambda (x) (syntax-case x () ((_ port fmt) #'(unpack fmt (get-bytevector-n port (format-size fmt)))) (var (identifier? #'var) #'get-unpack**))))) (define-syntax pack!* (lambda (x) (define (type c) (case c ((#\\c) (values #'(lambda (bv idx v _e) (bytevector-s8-set! bv idx v)) #'bytevector-s8-set! 1)) ((#\\C) (values #'(lambda (bv idx v _e) (bytevector-u8-set! bv idx v)) #'bytevector-u8-set! 1)) ((#\\s) (values #'bytevector-s16-set! #'bytevector-s16-native-set! 2)) ((#\\S) (values #'bytevector-u16-set! #'bytevector-u16-native-set! 2)) ((#\\l) (values #'bytevector-s32-set! #'bytevector-s32-native-set! 4)) ((#\\L) (values #'bytevector-u32-set! #'bytevector-u32-native-set! 4)) ((#\\q) (values #'bytevector-s64-set! #'bytevector-s64-native-set! 8)) ((#\\Q) (values #'bytevector-u64-set! #'bytevector-u64-native-set! 8)) ((#\\f) (values #'bytevector-ieee-single-set! #'bytevector-ieee-single-native-set! 4)) ((#\\d) (values #'bytevector-ieee-double-set! #'bytevector-ieee-double-native-set! 8)) (else (syntax-violation 'unpack \"Bad character in format string\" x c)))) (define (zero-fill start len) ;; Return code which sets the bytes between start and end to ;; zero. This is important in order to not inadvertently leak ;; data through uninitialized buffers. (do ((i 0 (+ i 1)) (e* '() (cons #`(bytevector-u8-set! bv (fx+ base-offset (fx+ #,start #,i)) 0) e*))) ((= i len) e*))) (define (roundb offset alignment) (bitwise-and (+ offset (- alignment 1)) (- alignment))) (syntax-case x () ((_ fmt* bytevector base-offset* vals ...) (with-syntax (((setters ...) (let ((fmt (syntax->datum #'fmt*))) (let lp ((i 0) (o 0) (rep #f) (endian #f) (align #t) (setters '()) (vals #'(vals ...))) (cond ((= i (string-length fmt)) (unless (null? (syntax->datum vals)) (syntax-violation #f \"Too many values for the format\" #'fmt*)) setters) ((char-whitespace? (string-ref fmt i)) (lp (+ i 1) o rep endian align setters vals)) (else (case (string-ref fmt i) ((#\\0 #\\1 #\\2 #\\3 #\\4 #\\5 #\\6 #\\7 #\\8 #\\9) (lp (+ i 1) o (+ (- (char->integer (string-ref fmt i)) (char->integer #\\0)) (* (if rep rep 0) 10)) endian align setters vals)) ((#\\=) (lp (+ i 1) o #f #f align setters vals)) ((#\\<) (lp (+ i 1) o #f #'(endianness little) align setters vals)) ((#\\> #\\!) (lp (+ i 1) o #f #'(endianness big) align setters vals)) ((#\\x) (lp (+ i 1) (+ o (or rep 1)) #f endian align (append (zero-fill o (or rep 1)) setters) vals)) ((#\\a) (lp (+ i 1) o #f endian #t setters vals)) ((#\\u) (lp (+ i 1) o #f endian #f setters vals)) (else ;use the type table (let-values ([(set nset n) (type (string-ref fmt i))]) (let ([rep (or rep 1)] [startoff (if align (roundb o n) o)]) (let lp* ((o^ startoff) (j 0) (setters (append (zero-fill o (- startoff o)) setters)) (vals vals)) (cond ((= j rep) (lp (+ i 1) (+ startoff (* n rep)) #f endian align setters vals)) (else (when (null? (syntax->datum vals)) (syntax-violation #f \"Too few values for the format\" #'fmt*)) (with-syntax ([(val1 vals ...) vals]) (let ([setter (cond (endian #`(#,set bv (fx+ base-offset #,o^) val1 #,endian)) ((or (not align) (not (and (integer? (syntax->datum #'base-offset*)) (eqv? 0 (mod (syntax->datum #'base-offset*) n))))) #`(#,set bv (fx+ base-offset #,o^) val1 (native-endianness))) (else #`(#,nset bv (fx+ base-offset #,o^) val1)))]) (lp* (+ o^ n) (+ j 1) (cons setter setters) #'(vals ...))))))))))))))))) #'(let ((bv bytevector) (base-offset base-offset*)) setters ... (values))))))) (define (pack!** fmt bv offset . vals) (define (type c) (case c ((#\\c) (values (lambda (bv idx v _e) (bytevector-s8-set! bv idx v)) 1)) ((#\\C) (values (lambda (bv idx v _e) (bytevector-u8-set! bv idx v)) 1)) ((#\\s) (values bytevector-s16-set! 2)) ((#\\S) (values bytevector-u16-set! 2)) ((#\\l) (values bytevector-s32-set! 4)) ((#\\L) (values bytevector-u32-set! 4)) ((#\\q) (values bytevector-s64-set! 8)) ((#\\Q) (values bytevector-u64-set! 8)) ((#\\f) (values bytevector-ieee-single-set! 4)) ((#\\d) (values bytevector-ieee-double-set! 8)) (else (error 'pack! \"Bad character in format string\" fmt c)))) (define (zero! i n) (do ((i i (fx+ i 1)) (m (fx+ i n))) ((fx=? i m)) (bytevector-u8-set! bv i 0))) (let lp ((i 0) (o 0) (rep #f) (endian (native-endianness)) (align #t) (vals vals)) (cond ((fx=? i (string-length fmt)) (unless (null? vals) (error 'pack! \"Too many values for the format\" fmt))) ((char-whitespace? (string-ref fmt i)) (lp (fx+ i 1) o rep endian align vals)) (else (case (string-ref fmt i) ((#\\0 #\\1 #\\2 #\\3 #\\4 #\\5 #\\6 #\\7 #\\8 #\\9) (lp (fx+ i 1) o (fx+ (fx- (char->integer (string-ref fmt i)) (char->integer #\\0)) (fx* (if rep rep 0) 10)) endian align vals)) ((#\\=) (lp (fx+ i 1) o #f (native-endianness) align vals)) ((#\\<) (lp (fx+ i 1) o #f (endianness little) align vals)) ((#\\> #\\!) (lp (fx+ i 1) o #f (endianness big) align vals)) ((#\\x) (zero! o (or rep 1)) (lp (fx+ i 1) (fx+ o (or rep 1)) #f endian align vals)) ((#\\a) (lp (fx+ i 1) o #f endian #t vals)) ((#\\u) (lp (fx+ i 1) o #f endian #f vals)) (else (let*-values (((set n) (type (string-ref fmt i))) ((o*) (if align (roundb o n) o))) (zero! o (fx- o* o)) (do ((rep (or rep 1) (fx- rep 1)) (o o* (+ o n)) (vals vals (cdr vals))) ((eqv? rep 0) (lp (fx+ i 1) (fx+ o (fx* n rep)) #f endian align vals)) (when (null? vals) (error 'pack! \"Too few values for the format\" fmt)) (set bv (fx+ offset o) (car vals) endian))))))))) (define-syntax pack! (make-variable-transformer (lambda (x) (syntax-case x () ((_ fmt bv offset vals ...) (string? (syntax->datum #'fmt)) #'(pack!* fmt bv offset vals ...)) ((_ . rest) #'(pack!** . rest)) (var (identifier? #'var) #'pack!**))))) (define (pack** fmt . values) (let ((bv (make-bytevector (format-size fmt)))) (apply pack! fmt bv 0 values) bv)) (define-syntax pack (make-variable-transformer (lambda (x) (syntax-case x () ((_ fmt vals ...) #'(let ((bv (make-bytevector (format-size fmt)))) (pack! fmt bv 0 vals ...) bv)) (var (identifier? #'var) #'pack**))))) (define (put-pack** port fmt . vals) (put-bytevector port (apply pack fmt vals))) (define-syntax put-pack (make-variable-transformer (lambda (x) (syntax-case x () ((_ port fmt vals ...) #'(put-bytevector port (pack fmt vals ...))) ((_ . rest) #'(put-pack** . rest)) (var (identifier? #'var) #'put-pack**)))))) ")))) (for-each (match-lambda ((directory) (mkdir directory)) ((filename . contents) (call-with-output-file filename (lambda (port) (display contents port))))) files))