diff options
| -rw-r--r-- | guix/utils.scm | 130 | ||||
| -rw-r--r-- | tests/utils.scm | 16 |
2 files changed, 146 insertions, 0 deletions
diff --git a/guix/utils.scm b/guix/utils.scm index 2ffecbfab9..65e89a0e1b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -22,6 +22,7 @@ #:use-module (srfi srfi-39) #:use-module (srfi srfi-60) #:use-module (rnrs bytevectors) + #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) #:autoload (ice-9 rdelim) (read-line) @@ -32,6 +33,8 @@ bytevector->base32-string bytevector->nix-base32-string bytevector->base16-string + base32-string->bytevector + nix-base32-string->bytevector sha256 %nixpkgs-directory @@ -169,6 +172,133 @@ the previous application or INIT." (make-bytevector->base32-string bytevector-quintet-fold-right %nix-base32-chars)) + +(define bytevector-quintet-set! + (let* ((setq! (lambda (bv offset start stop value) + (let ((v (bytevector-u8-ref bv offset)) + (w (arithmetic-shift value start)) + (m (bitwise-xor (1- (expt 2 stop)) + (1- (expt 2 start))))) + (bytevector-u8-set! bv offset + (bitwise-merge m w v))))) + (set0! (lambda (bv offset value) + (setq! bv offset 3 8 value))) + (set1! (lambda (bv offset value) + (setq! bv offset 0 3 (bit-field value 2 5)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2))))) + (set2! (lambda (bv offset value) + (setq! bv offset 1 6 value))) + (set3! (lambda (bv offset value) + (setq! bv offset 0 1 (bit-field value 4 5)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4))))) + (set4! (lambda (bv offset value) + (setq! bv offset 0 4 (bit-field value 1 5)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1))))) + (set5! (lambda (bv offset value) + (setq! bv offset 2 7 value))) + (set6! (lambda (bv offset value) + (setq! bv offset 0 2 (bit-field value 3 5)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3))))) + (set7! (lambda (bv offset value) + (setq! bv offset 0 5 value))) + (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) + (lambda (bv index value) + "Set the INDEXth quintet of BV to VALUE." + (let ((p (vector-ref sets (modulo index 8)))) + (p bv (quotient (* index 5) 8) (logand value #x1f)))))) + +(define bytevector-quintet-set-right! + (let* ((setq! (lambda (bv offset start stop value) + (let ((v (bytevector-u8-ref bv offset)) + (w (arithmetic-shift value start)) + (m (bitwise-xor (1- (expt 2 stop)) + (1- (expt 2 start))))) + (bytevector-u8-set! bv offset + (bitwise-merge m w v))))) + (set0! (lambda (bv offset value) + (setq! bv offset 0 5 value))) + (set1! (lambda (bv offset value) + (setq! bv offset 5 8 (bit-field value 0 3)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5))))) + (set2! (lambda (bv offset value) + (setq! bv offset 2 7 value))) + (set3! (lambda (bv offset value) + (setq! bv offset 7 8 (bit-field value 0 1)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5))))) + (set4! (lambda (bv offset value) + (setq! bv offset 4 8 (bit-field value 0 4)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5))))) + (set5! (lambda (bv offset value) + (setq! bv offset 1 6 value))) + (set6! (lambda (bv offset value) + (setq! bv offset 6 8 (bit-field value 0 2)) + (or (= (+ 1 offset) (bytevector-length bv)) + (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5))))) + (set7! (lambda (bv offset value) + (setq! bv offset 3 8 value))) + (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) + (lambda (bv index value) + "Set the INDEXth quintet of BV to VALUE, assuming quintets start from +the least-significant bits." + (let ((p (vector-ref sets (modulo index 8)))) + (p bv (quotient (* index 5) 8) (logand value #x1f)))))) + +(define (base32-string-unfold f s) + "Given procedure F which, when applied to a character, returns the +corresponding quintet, return the bytevector corresponding to string S." + (define len (string-length s)) + + (let ((bv (make-bytevector (quotient (* len 5) 8)))) + (string-fold (lambda (chr index) + (bytevector-quintet-set! bv index (f chr)) + (+ 1 index)) + 0 + s) + bv)) + +(define (base32-string-unfold-right f s) + "Given procedure F which, when applied to a character, returns the +corresponding quintet, return the bytevector corresponding to string S, +starting from the right of S." + (define len (string-length s)) + + (let ((bv (make-bytevector (quotient (* len 5) 8)))) + (string-fold-right (lambda (chr index) + (bytevector-quintet-set-right! bv index (f chr)) + (+ 1 index)) + 0 + s) + bv)) + +(define (make-base32-string->bytevector base32-string-unfold base32-chars) + (let ((char->value (let loop ((i 0) + (v vlist-null)) + (if (= i (vector-length base32-chars)) + v + (loop (+ 1 i) + (vhash-consv (vector-ref base32-chars i) + i v)))))) + (lambda (s) + "Return the binary representation of base32 string S as a bytevector." + (base32-string-unfold (lambda (chr) + (or (and=> (vhash-assv chr char->value) cdr) + (error "invalid base32 character" chr))) + s)))) + +(define base32-string->bytevector + (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars)) + +(define nix-base32-string->bytevector + (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars)) + + ;;; ;;; Base 16. diff --git a/tests/utils.scm b/tests/utils.scm index eade84b5d4..edea11db72 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -46,6 +46,22 @@ "mzxw6ytb" "mzxw6ytboi"))) +(test-assert "base32-string->bytevector" + (every (lambda (bv) + (equal? (base32-string->bytevector + (bytevector->base32-string bv)) + bv)) + ;; Examples from RFC 4648. + (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) + +(test-assert "nix-base32-string->bytevector" + (every (lambda (bv) + (equal? (nix-base32-string->bytevector + (bytevector->nix-base32-string bv)) + bv)) + ;; Examples from RFC 4648. + (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) + ;; The following tests requires `nix-hash' in $PATH. (test-skip (if (false-if-exception (system* "nix-hash" "--version")) 0 |