futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add base32-string->bytevector' and nix-base32-string->bytevector'.

Browse Source 
* guix/utils.scm (bytevector-quintet-set!,
  bytevector-quintet-set-right!, base32-string-unfold,
  base32-string-unfold-right, make-base32-string->bytevector,
  base32-string->bytevector, nix-base32-string->bytevector): New
  procedures.

* tests/utils.scm ("base32-string->bytevector",
  "nix-base32-string->bytevector"): New tests.
This commit is contained in:
Ludovic Courtès 2012-06-09 15:25:51 +02:00
parent 4255d4e3c5
commit c8369cacce
2 changed files with 146 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

130
guix/utils.scm
View File

@ -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.

16
tests/utils.scm
View File

@ -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