diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | guix-download.in | 1 | ||||
| -rw-r--r-- | guix.scm | 3 | ||||
| -rw-r--r-- | guix/base32.scm | 288 | ||||
| -rw-r--r-- | guix/derivations.scm | 1 | ||||
| -rw-r--r-- | guix/packages.scm | 1 | ||||
| -rw-r--r-- | guix/snix.scm | 1 | ||||
| -rw-r--r-- | guix/utils.scm | 264 | ||||
| -rw-r--r-- | tests/base32.scm | 93 | ||||
| -rw-r--r-- | tests/builders.scm | 1 | ||||
| -rw-r--r-- | tests/derivations.scm | 1 | ||||
| -rw-r--r-- | tests/utils.scm | 58 |
12 files changed, 392 insertions, 322 deletions
diff --git a/Makefile.am b/Makefile.am index b0fefae968a..b29bf6584b2 100644 --- a/Makefile.am +++ b/Makefile.am | |||
| @@ -23,6 +23,7 @@ bin_SCRIPTS = \ | |||
| 23 | guix-package | 23 | guix-package |
| 24 | 24 | ||
| 25 | MODULES = \ | 25 | MODULES = \ |
| 26 | guix/base32.scm \ | ||
| 26 | guix/utils.scm \ | 27 | guix/utils.scm \ |
| 27 | guix/derivations.scm \ | 28 | guix/derivations.scm \ |
| 28 | guix/build-system.scm \ | 29 | guix/build-system.scm \ |
| @@ -137,6 +138,7 @@ distro/packages/bootstrap/i686-linux/guile-bootstrap-2.0.6.tar.xz: | |||
| 137 | nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm | 138 | nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm |
| 138 | 139 | ||
| 139 | TESTS = \ | 140 | TESTS = \ |
| 141 | tests/base32.scm \ | ||
| 140 | tests/builders.scm \ | 142 | tests/builders.scm \ |
| 141 | tests/derivations.scm \ | 143 | tests/derivations.scm \ |
| 142 | tests/utils.scm \ | 144 | tests/utils.scm \ |
diff --git a/guix-download.in b/guix-download.in index 8a3c2c4100d..46efaa17e80 100644 --- a/guix-download.in +++ b/guix-download.in | |||
| @@ -36,6 +36,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ | |||
| 36 | #:use-module (guix ui) | 36 | #:use-module (guix ui) |
| 37 | #:use-module (guix store) | 37 | #:use-module (guix store) |
| 38 | #:use-module (guix utils) | 38 | #:use-module (guix utils) |
| 39 | #:use-module (guix base32) | ||
| 39 | #:use-module (guix ftp-client) | 40 | #:use-module (guix ftp-client) |
| 40 | #:use-module (ice-9 match) | 41 | #:use-module (ice-9 match) |
| 41 | #:use-module (srfi srfi-1) | 42 | #:use-module (srfi srfi-1) |
| @@ -23,7 +23,8 @@ | |||
| 23 | (eval-when (eval load compile) | 23 | (eval-when (eval load compile) |
| 24 | (begin | 24 | (begin |
| 25 | (define %public-modules | 25 | (define %public-modules |
| 26 | '(build-system | 26 | '(base32 |
| 27 | build-system | ||
| 27 | derivations | 28 | derivations |
| 28 | ftp-client | 29 | ftp-client |
| 29 | ftp | 30 | ftp |
diff --git a/guix/base32.scm b/guix/base32.scm new file mode 100644 index 00000000000..6f0a92bd999 --- /dev/null +++ b/guix/base32.scm | |||
| @@ -0,0 +1,288 @@ | |||
| 1 | ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- | ||
| 2 | ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (guix base32) | ||
| 20 | #:use-module (srfi srfi-1) | ||
| 21 | #:use-module (srfi srfi-60) | ||
| 22 | #:use-module (rnrs bytevectors) | ||
| 23 | #:use-module (ice-9 vlist) | ||
| 24 | #:export (bytevector-quintet-length | ||
| 25 | bytevector->base32-string | ||
| 26 | bytevector->nix-base32-string | ||
| 27 | base32-string->bytevector | ||
| 28 | nix-base32-string->bytevector)) | ||
| 29 | |||
| 30 | ;;; Commentary: | ||
| 31 | ;;; | ||
| 32 | ;;; A generic, customizable to convert bytevectors to/from a base32 | ||
| 33 | ;;; representation. | ||
| 34 | ;;; | ||
| 35 | ;;; Code: | ||
| 36 | |||
| 37 | (define bytevector-quintet-ref | ||
| 38 | (let* ((ref bytevector-u8-ref) | ||
| 39 | (ref+ (lambda (bv offset) | ||
| 40 | (let ((o (+ 1 offset))) | ||
| 41 | (if (>= o (bytevector-length bv)) | ||
| 42 | 0 | ||
| 43 | (bytevector-u8-ref bv o))))) | ||
| 44 | (ref0 (lambda (bv offset) | ||
| 45 | (bit-field (ref bv offset) 3 8))) | ||
| 46 | (ref1 (lambda (bv offset) | ||
| 47 | (logior (ash (bit-field (ref bv offset) 0 3) 2) | ||
| 48 | (bit-field (ref+ bv offset) 6 8)))) | ||
| 49 | (ref2 (lambda (bv offset) | ||
| 50 | (bit-field (ref bv offset) 1 6))) | ||
| 51 | (ref3 (lambda (bv offset) | ||
| 52 | (logior (ash (bit-field (ref bv offset) 0 1) 4) | ||
| 53 | (bit-field (ref+ bv offset) 4 8)))) | ||
| 54 | (ref4 (lambda (bv offset) | ||
| 55 | (logior (ash (bit-field (ref bv offset) 0 4) 1) | ||
| 56 | (bit-field (ref+ bv offset) 7 8)))) | ||
| 57 | (ref5 (lambda (bv offset) | ||
| 58 | (bit-field (ref bv offset) 2 7))) | ||
| 59 | (ref6 (lambda (bv offset) | ||
| 60 | (logior (ash (bit-field (ref bv offset) 0 2) 3) | ||
| 61 | (bit-field (ref+ bv offset) 5 8)))) | ||
| 62 | (ref7 (lambda (bv offset) | ||
| 63 | (bit-field (ref bv offset) 0 5))) | ||
| 64 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | ||
| 65 | (lambda (bv index) | ||
| 66 | "Return the INDEXth quintet of BV." | ||
| 67 | (let ((p (vector-ref refs (modulo index 8)))) | ||
| 68 | (p bv (quotient (* index 5) 8)))))) | ||
| 69 | |||
| 70 | (define bytevector-quintet-ref-right | ||
| 71 | (let* ((ref bytevector-u8-ref) | ||
| 72 | (ref+ (lambda (bv offset) | ||
| 73 | (let ((o (+ 1 offset))) | ||
| 74 | (if (>= o (bytevector-length bv)) | ||
| 75 | 0 | ||
| 76 | (bytevector-u8-ref bv o))))) | ||
| 77 | (ref0 (lambda (bv offset) | ||
| 78 | (bit-field (ref bv offset) 0 5))) | ||
| 79 | (ref1 (lambda (bv offset) | ||
| 80 | (logior (bit-field (ref bv offset) 5 8) | ||
| 81 | (ash (bit-field (ref+ bv offset) 0 2) 3)))) | ||
| 82 | (ref2 (lambda (bv offset) | ||
| 83 | (bit-field (ref bv offset) 2 7))) | ||
| 84 | (ref3 (lambda (bv offset) | ||
| 85 | (logior (bit-field (ref bv offset) 7 8) | ||
| 86 | (ash (bit-field (ref+ bv offset) 0 4) 1)))) | ||
| 87 | (ref4 (lambda (bv offset) | ||
| 88 | (logior (bit-field (ref bv offset) 4 8) | ||
| 89 | (ash (bit-field (ref+ bv offset) 0 1) 4)))) | ||
| 90 | (ref5 (lambda (bv offset) | ||
| 91 | (bit-field (ref bv offset) 1 6))) | ||
| 92 | (ref6 (lambda (bv offset) | ||
| 93 | (logior (bit-field (ref bv offset) 6 8) | ||
| 94 | (ash (bit-field (ref+ bv offset) 0 3) 2)))) | ||
| 95 | (ref7 (lambda (bv offset) | ||
| 96 | (bit-field (ref bv offset) 3 8))) | ||
| 97 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | ||
| 98 | (lambda (bv index) | ||
| 99 | "Return the INDEXth quintet of BV, assuming quintets start from the | ||
| 100 | least-significant bits, contrary to what RFC 4648 describes." | ||
| 101 | (let ((p (vector-ref refs (modulo index 8)))) | ||
| 102 | (p bv (quotient (* index 5) 8)))))) | ||
| 103 | |||
| 104 | (define (bytevector-quintet-length bv) | ||
| 105 | "Return the number of quintets (including truncated ones) available in BV." | ||
| 106 | (ceiling (/ (* (bytevector-length bv) 8) 5))) | ||
| 107 | |||
| 108 | (define (bytevector-quintet-fold proc init bv) | ||
| 109 | "Return the result of applying PROC to each quintet of BV and the result of | ||
| 110 | the previous application or INIT." | ||
| 111 | (define len | ||
| 112 | (bytevector-quintet-length bv)) | ||
| 113 | |||
| 114 | (let loop ((i 0) | ||
| 115 | (r init)) | ||
| 116 | (if (= i len) | ||
| 117 | r | ||
| 118 | (loop (1+ i) (proc (bytevector-quintet-ref bv i) r))))) | ||
| 119 | |||
| 120 | (define (bytevector-quintet-fold-right proc init bv) | ||
| 121 | "Return the result of applying PROC to each quintet of BV and the result of | ||
| 122 | the previous application or INIT." | ||
| 123 | (define len | ||
| 124 | (bytevector-quintet-length bv)) | ||
| 125 | |||
| 126 | (let loop ((i len) | ||
| 127 | (r init)) | ||
| 128 | (if (zero? i) | ||
| 129 | r | ||
| 130 | (let ((j (- i 1))) | ||
| 131 | (loop j (proc (bytevector-quintet-ref-right bv j) r)))))) | ||
| 132 | |||
| 133 | (define (make-bytevector->base32-string quintet-fold base32-chars) | ||
| 134 | (lambda (bv) | ||
| 135 | "Return a base32 encoding of BV using BASE32-CHARS as the alphabet." | ||
| 136 | (let ((chars (quintet-fold (lambda (q r) | ||
| 137 | (cons (vector-ref base32-chars q) | ||
| 138 | r)) | ||
| 139 | '() | ||
| 140 | bv))) | ||
| 141 | (list->string (reverse chars))))) | ||
| 142 | |||
| 143 | (define %nix-base32-chars | ||
| 144 | ;; See `libutil/hash.cc'. | ||
| 145 | #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 | ||
| 146 | #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n | ||
| 147 | #\p #\q #\r #\s #\v #\w #\x #\y #\z)) | ||
| 148 | |||
| 149 | (define %rfc4648-base32-chars | ||
| 150 | #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m | ||
| 151 | #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z | ||
| 152 | #\2 #\3 #\4 #\5 #\6 #\7)) | ||
| 153 | |||
| 154 | (define bytevector->base32-string | ||
| 155 | (make-bytevector->base32-string bytevector-quintet-fold | ||
| 156 | %rfc4648-base32-chars)) | ||
| 157 | |||
| 158 | (define bytevector->nix-base32-string | ||
| 159 | (make-bytevector->base32-string bytevector-quintet-fold-right | ||
| 160 | %nix-base32-chars)) | ||
| 161 | |||
| 162 | |||
| 163 | (define bytevector-quintet-set! | ||
| 164 | (let* ((setq! (lambda (bv offset start stop value) | ||
| 165 | (let ((v (bytevector-u8-ref bv offset)) | ||
| 166 | (w (arithmetic-shift value start)) | ||
| 167 | (m (bitwise-xor (1- (expt 2 stop)) | ||
| 168 | (1- (expt 2 start))))) | ||
| 169 | (bytevector-u8-set! bv offset | ||
| 170 | (bitwise-merge m w v))))) | ||
| 171 | (set0! (lambda (bv offset value) | ||
| 172 | (setq! bv offset 3 8 value))) | ||
| 173 | (set1! (lambda (bv offset value) | ||
| 174 | (setq! bv offset 0 3 (bit-field value 2 5)) | ||
| 175 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 176 | (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2))))) | ||
| 177 | (set2! (lambda (bv offset value) | ||
| 178 | (setq! bv offset 1 6 value))) | ||
| 179 | (set3! (lambda (bv offset value) | ||
| 180 | (setq! bv offset 0 1 (bit-field value 4 5)) | ||
| 181 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 182 | (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4))))) | ||
| 183 | (set4! (lambda (bv offset value) | ||
| 184 | (setq! bv offset 0 4 (bit-field value 1 5)) | ||
| 185 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 186 | (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1))))) | ||
| 187 | (set5! (lambda (bv offset value) | ||
| 188 | (setq! bv offset 2 7 value))) | ||
| 189 | (set6! (lambda (bv offset value) | ||
| 190 | (setq! bv offset 0 2 (bit-field value 3 5)) | ||
| 191 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 192 | (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3))))) | ||
| 193 | (set7! (lambda (bv offset value) | ||
| 194 | (setq! bv offset 0 5 value))) | ||
| 195 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | ||
| 196 | (lambda (bv index value) | ||
| 197 | "Set the INDEXth quintet of BV to VALUE." | ||
| 198 | (let ((p (vector-ref sets (modulo index 8)))) | ||
| 199 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | ||
| 200 | |||
| 201 | (define bytevector-quintet-set-right! | ||
| 202 | (let* ((setq! (lambda (bv offset start stop value) | ||
| 203 | (let ((v (bytevector-u8-ref bv offset)) | ||
| 204 | (w (arithmetic-shift value start)) | ||
| 205 | (m (bitwise-xor (1- (expt 2 stop)) | ||
| 206 | (1- (expt 2 start))))) | ||
| 207 | (bytevector-u8-set! bv offset | ||
| 208 | (bitwise-merge m w v))))) | ||
| 209 | (set0! (lambda (bv offset value) | ||
| 210 | (setq! bv offset 0 5 value))) | ||
| 211 | (set1! (lambda (bv offset value) | ||
| 212 | (setq! bv offset 5 8 (bit-field value 0 3)) | ||
| 213 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 214 | (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5))))) | ||
| 215 | (set2! (lambda (bv offset value) | ||
| 216 | (setq! bv offset 2 7 value))) | ||
| 217 | (set3! (lambda (bv offset value) | ||
| 218 | (setq! bv offset 7 8 (bit-field value 0 1)) | ||
| 219 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 220 | (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5))))) | ||
| 221 | (set4! (lambda (bv offset value) | ||
| 222 | (setq! bv offset 4 8 (bit-field value 0 4)) | ||
| 223 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 224 | (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5))))) | ||
| 225 | (set5! (lambda (bv offset value) | ||
| 226 | (setq! bv offset 1 6 value))) | ||
| 227 | (set6! (lambda (bv offset value) | ||
| 228 | (setq! bv offset 6 8 (bit-field value 0 2)) | ||
| 229 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 230 | (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5))))) | ||
| 231 | (set7! (lambda (bv offset value) | ||
| 232 | (setq! bv offset 3 8 value))) | ||
| 233 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | ||
| 234 | (lambda (bv index value) | ||
| 235 | "Set the INDEXth quintet of BV to VALUE, assuming quintets start from | ||
| 236 | the least-significant bits." | ||
| 237 | (let ((p (vector-ref sets (modulo index 8)))) | ||
| 238 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | ||
| 239 | |||
| 240 | (define (base32-string-unfold f s) | ||
| 241 | "Given procedure F which, when applied to a character, returns the | ||
| 242 | corresponding quintet, return the bytevector corresponding to string S." | ||
| 243 | (define len (string-length s)) | ||
| 244 | |||
| 245 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | ||
| 246 | (string-fold (lambda (chr index) | ||
| 247 | (bytevector-quintet-set! bv index (f chr)) | ||
| 248 | (+ 1 index)) | ||
| 249 | 0 | ||
| 250 | s) | ||
| 251 | bv)) | ||
| 252 | |||
| 253 | (define (base32-string-unfold-right f s) | ||
| 254 | "Given procedure F which, when applied to a character, returns the | ||
| 255 | corresponding quintet, return the bytevector corresponding to string S, | ||
| 256 | starting from the right of S." | ||
| 257 | (define len (string-length s)) | ||
| 258 | |||
| 259 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | ||
| 260 | (string-fold-right (lambda (chr index) | ||
| 261 | (bytevector-quintet-set-right! bv index (f chr)) | ||
| 262 | (+ 1 index)) | ||
| 263 | 0 | ||
| 264 | s) | ||
| 265 | bv)) | ||
| 266 | |||
| 267 | (define (make-base32-string->bytevector base32-string-unfold base32-chars) | ||
| 268 | (let ((char->value (let loop ((i 0) | ||
| 269 | (v vlist-null)) | ||
| 270 | (if (= i (vector-length base32-chars)) | ||
| 271 | v | ||
| 272 | (loop (+ 1 i) | ||
| 273 | (vhash-consv (vector-ref base32-chars i) | ||
| 274 | i v)))))) | ||
| 275 | (lambda (s) | ||
| 276 | "Return the binary representation of base32 string S as a bytevector." | ||
| 277 | (base32-string-unfold (lambda (chr) | ||
| 278 | (or (and=> (vhash-assv chr char->value) cdr) | ||
| 279 | (error "invalid base32 character" chr))) | ||
| 280 | s)))) | ||
| 281 | |||
| 282 | (define base32-string->bytevector | ||
| 283 | (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars)) | ||
| 284 | |||
| 285 | (define nix-base32-string->bytevector | ||
| 286 | (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars)) | ||
| 287 | |||
| 288 | ;;; base32.scm ends here | ||
diff --git a/guix/derivations.scm b/guix/derivations.scm index cbf755ab633..cda1f065d47 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm | |||
| @@ -26,6 +26,7 @@ | |||
| 26 | #:use-module (ice-9 rdelim) | 26 | #:use-module (ice-9 rdelim) |
| 27 | #:use-module (guix store) | 27 | #:use-module (guix store) |
| 28 | #:use-module (guix utils) | 28 | #:use-module (guix utils) |
| 29 | #:use-module (guix base32) | ||
| 29 | #:export (<derivation> | 30 | #:export (<derivation> |
| 30 | derivation? | 31 | derivation? |
| 31 | derivation-outputs | 32 | derivation-outputs |
diff --git a/guix/packages.scm b/guix/packages.scm index 9d1dbe7dc49..23761f41012 100644 --- a/guix/packages.scm +++ b/guix/packages.scm | |||
| @@ -19,6 +19,7 @@ | |||
| 19 | (define-module (guix packages) | 19 | (define-module (guix packages) |
| 20 | #:use-module (guix utils) | 20 | #:use-module (guix utils) |
| 21 | #:use-module (guix store) | 21 | #:use-module (guix store) |
| 22 | #:use-module (guix base32) | ||
| 22 | #:use-module (guix build-system) | 23 | #:use-module (guix build-system) |
| 23 | #:use-module (ice-9 match) | 24 | #:use-module (ice-9 match) |
| 24 | #:use-module (srfi srfi-1) | 25 | #:use-module (srfi srfi-1) |
diff --git a/guix/snix.scm b/guix/snix.scm index ef98eb42a07..c6a9bee6a72 100644 --- a/guix/snix.scm +++ b/guix/snix.scm | |||
| @@ -32,6 +32,7 @@ | |||
| 32 | #:use-module (system foreign) | 32 | #:use-module (system foreign) |
| 33 | #:use-module (rnrs bytevectors) | 33 | #:use-module (rnrs bytevectors) |
| 34 | #:use-module (guix utils) | 34 | #:use-module (guix utils) |
| 35 | #:use-module (guix base32) | ||
| 35 | #:use-module (guix config) | 36 | #:use-module (guix config) |
| 36 | #:export (open-nixpkgs | 37 | #:export (open-nixpkgs |
| 37 | xml->snix | 38 | xml->snix |
diff --git a/guix/utils.scm b/guix/utils.scm index fa5abadc7a9..ff8730aa632 100644 --- a/guix/utils.scm +++ b/guix/utils.scm | |||
| @@ -33,12 +33,7 @@ | |||
| 33 | #:use-module (ice-9 match) | 33 | #:use-module (ice-9 match) |
| 34 | #:use-module (ice-9 format) | 34 | #:use-module (ice-9 format) |
| 35 | #:autoload (system foreign) (pointer->procedure) | 35 | #:autoload (system foreign) (pointer->procedure) |
| 36 | #:export (bytevector-quintet-length | 36 | #:export (bytevector->base16-string |
| 37 | bytevector->base32-string | ||
| 38 | bytevector->nix-base32-string | ||
| 39 | bytevector->base16-string | ||
| 40 | base32-string->bytevector | ||
| 41 | nix-base32-string->bytevector | ||
| 42 | base16-string->bytevector | 37 | base16-string->bytevector |
| 43 | sha256 | 38 | sha256 |
| 44 | 39 | ||
| @@ -81,263 +76,6 @@ evaluate to a simple datum." | |||
| 81 | 76 | ||
| 82 | 77 | ||
| 83 | ;;; | 78 | ;;; |
| 84 | ;;; Base 32. | ||
| 85 | ;;; | ||
| 86 | |||
| 87 | (define bytevector-quintet-ref | ||
| 88 | (let* ((ref bytevector-u8-ref) | ||
| 89 | (ref+ (lambda (bv offset) | ||
| 90 | (let ((o (+ 1 offset))) | ||
| 91 | (if (>= o (bytevector-length bv)) | ||
| 92 | 0 | ||
| 93 | (bytevector-u8-ref bv o))))) | ||
| 94 | (ref0 (lambda (bv offset) | ||
| 95 | (bit-field (ref bv offset) 3 8))) | ||
| 96 | (ref1 (lambda (bv offset) | ||
| 97 | (logior (ash (bit-field (ref bv offset) 0 3) 2) | ||
| 98 | (bit-field (ref+ bv offset) 6 8)))) | ||
| 99 | (ref2 (lambda (bv offset) | ||
| 100 | (bit-field (ref bv offset) 1 6))) | ||
| 101 | (ref3 (lambda (bv offset) | ||
| 102 | (logior (ash (bit-field (ref bv offset) 0 1) 4) | ||
| 103 | (bit-field (ref+ bv offset) 4 8)))) | ||
| 104 | (ref4 (lambda (bv offset) | ||
| 105 | (logior (ash (bit-field (ref bv offset) 0 4) 1) | ||
| 106 | (bit-field (ref+ bv offset) 7 8)))) | ||
| 107 | (ref5 (lambda (bv offset) | ||
| 108 | (bit-field (ref bv offset) 2 7))) | ||
| 109 | (ref6 (lambda (bv offset) | ||
| 110 | (logior (ash (bit-field (ref bv offset) 0 2) 3) | ||
| 111 | (bit-field (ref+ bv offset) 5 8)))) | ||
| 112 | (ref7 (lambda (bv offset) | ||
| 113 | (bit-field (ref bv offset) 0 5))) | ||
| 114 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | ||
| 115 | (lambda (bv index) | ||
| 116 | "Return the INDEXth quintet of BV." | ||
| 117 | (let ((p (vector-ref refs (modulo index 8)))) | ||
| 118 | (p bv (quotient (* index 5) 8)))))) | ||
| 119 | |||
| 120 | (define bytevector-quintet-ref-right | ||
| 121 | (let* ((ref bytevector-u8-ref) | ||
| 122 | (ref+ (lambda (bv offset) | ||
| 123 | (let ((o (+ 1 offset))) | ||
| 124 | (if (>= o (bytevector-length bv)) | ||
| 125 | 0 | ||
| 126 | (bytevector-u8-ref bv o))))) | ||
| 127 | (ref0 (lambda (bv offset) | ||
| 128 | (bit-field (ref bv offset) 0 5))) | ||
| 129 | (ref1 (lambda (bv offset) | ||
| 130 | (logior (bit-field (ref bv offset) 5 8) | ||
| 131 | (ash (bit-field (ref+ bv offset) 0 2) 3)))) | ||
| 132 | (ref2 (lambda (bv offset) | ||
| 133 | (bit-field (ref bv offset) 2 7))) | ||
| 134 | (ref3 (lambda (bv offset) | ||
| 135 | (logior (bit-field (ref bv offset) 7 8) | ||
| 136 | (ash (bit-field (ref+ bv offset) 0 4) 1)))) | ||
| 137 | (ref4 (lambda (bv offset) | ||
| 138 | (logior (bit-field (ref bv offset) 4 8) | ||
| 139 | (ash (bit-field (ref+ bv offset) 0 1) 4)))) | ||
| 140 | (ref5 (lambda (bv offset) | ||
| 141 | (bit-field (ref bv offset) 1 6))) | ||
| 142 | (ref6 (lambda (bv offset) | ||
| 143 | (logior (bit-field (ref bv offset) 6 8) | ||
| 144 | (ash (bit-field (ref+ bv offset) 0 3) 2)))) | ||
| 145 | (ref7 (lambda (bv offset) | ||
| 146 | (bit-field (ref bv offset) 3 8))) | ||
| 147 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | ||
| 148 | (lambda (bv index) | ||
| 149 | "Return the INDEXth quintet of BV, assuming quintets start from the | ||
| 150 | least-significant bits, contrary to what RFC 4648 describes." | ||
| 151 | (let ((p (vector-ref refs (modulo index 8)))) | ||
| 152 | (p bv (quotient (* index 5) 8)))))) | ||
| 153 | |||
| 154 | (define (bytevector-quintet-length bv) | ||
| 155 | "Return the number of quintets (including truncated ones) available in BV." | ||
| 156 | (ceiling (/ (* (bytevector-length bv) 8) 5))) | ||
| 157 | |||
| 158 | (define (bytevector-quintet-fold proc init bv) | ||
| 159 | "Return the result of applying PROC to each quintet of BV and the result of | ||
| 160 | the previous application or INIT." | ||
| 161 | (define len | ||
| 162 | (bytevector-quintet-length bv)) | ||
| 163 | |||
| 164 | (let loop ((i 0) | ||
| 165 | (r init)) | ||
| 166 | (if (= i len) | ||
| 167 | r | ||
| 168 | (loop (1+ i) (proc (bytevector-quintet-ref bv i) r))))) | ||
| 169 | |||
| 170 | (define (bytevector-quintet-fold-right proc init bv) | ||
| 171 | "Return the result of applying PROC to each quintet of BV and the result of | ||
| 172 | the previous application or INIT." | ||
| 173 | (define len | ||
| 174 | (bytevector-quintet-length bv)) | ||
| 175 | |||
| 176 | (let loop ((i len) | ||
| 177 | (r init)) | ||
| 178 | (if (zero? i) | ||
| 179 | r | ||
| 180 | (let ((j (- i 1))) | ||
| 181 | (loop j (proc (bytevector-quintet-ref-right bv j) r)))))) | ||
| 182 | |||
| 183 | (define (make-bytevector->base32-string quintet-fold base32-chars) | ||
| 184 | (lambda (bv) | ||
| 185 | "Return a base32 encoding of BV using BASE32-CHARS as the alphabet." | ||
| 186 | (let ((chars (quintet-fold (lambda (q r) | ||
| 187 | (cons (vector-ref base32-chars q) | ||
| 188 | r)) | ||
| 189 | '() | ||
| 190 | bv))) | ||
| 191 | (list->string (reverse chars))))) | ||
| 192 | |||
| 193 | (define %nix-base32-chars | ||
| 194 | ;; See `libutil/hash.cc'. | ||
| 195 | #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 | ||
| 196 | #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n | ||
| 197 | #\p #\q #\r #\s #\v #\w #\x #\y #\z)) | ||
| 198 | |||
| 199 | (define %rfc4648-base32-chars | ||
| 200 | #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m | ||
| 201 | #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z | ||
| 202 | #\2 #\3 #\4 #\5 #\6 #\7)) | ||
| 203 | |||
| 204 | (define bytevector->base32-string | ||
| 205 | (make-bytevector->base32-string bytevector-quintet-fold | ||
| 206 | %rfc4648-base32-chars)) | ||
| 207 | |||
| 208 | (define bytevector->nix-base32-string | ||
| 209 | (make-bytevector->base32-string bytevector-quintet-fold-right | ||
| 210 | %nix-base32-chars)) | ||
| 211 | |||
| 212 | |||
| 213 | (define bytevector-quintet-set! | ||
| 214 | (let* ((setq! (lambda (bv offset start stop value) | ||
| 215 | (let ((v (bytevector-u8-ref bv offset)) | ||
| 216 | (w (arithmetic-shift value start)) | ||
| 217 | (m (bitwise-xor (1- (expt 2 stop)) | ||
| 218 | (1- (expt 2 start))))) | ||
| 219 | (bytevector-u8-set! bv offset | ||
| 220 | (bitwise-merge m w v))))) | ||
| 221 | (set0! (lambda (bv offset value) | ||
| 222 | (setq! bv offset 3 8 value))) | ||
| 223 | (set1! (lambda (bv offset value) | ||
| 224 | (setq! bv offset 0 3 (bit-field value 2 5)) | ||
| 225 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 226 | (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2))))) | ||
| 227 | (set2! (lambda (bv offset value) | ||
| 228 | (setq! bv offset 1 6 value))) | ||
| 229 | (set3! (lambda (bv offset value) | ||
| 230 | (setq! bv offset 0 1 (bit-field value 4 5)) | ||
| 231 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 232 | (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4))))) | ||
| 233 | (set4! (lambda (bv offset value) | ||
| 234 | (setq! bv offset 0 4 (bit-field value 1 5)) | ||
| 235 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 236 | (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1))))) | ||
| 237 | (set5! (lambda (bv offset value) | ||
| 238 | (setq! bv offset 2 7 value))) | ||
| 239 | (set6! (lambda (bv offset value) | ||
| 240 | (setq! bv offset 0 2 (bit-field value 3 5)) | ||
| 241 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 242 | (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3))))) | ||
| 243 | (set7! (lambda (bv offset value) | ||
| 244 | (setq! bv offset 0 5 value))) | ||
| 245 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | ||
| 246 | (lambda (bv index value) | ||
| 247 | "Set the INDEXth quintet of BV to VALUE." | ||
| 248 | (let ((p (vector-ref sets (modulo index 8)))) | ||
| 249 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | ||
| 250 | |||
| 251 | (define bytevector-quintet-set-right! | ||
| 252 | (let* ((setq! (lambda (bv offset start stop value) | ||
| 253 | (let ((v (bytevector-u8-ref bv offset)) | ||
| 254 | (w (arithmetic-shift value start)) | ||
| 255 | (m (bitwise-xor (1- (expt 2 stop)) | ||
| 256 | (1- (expt 2 start))))) | ||
| 257 | (bytevector-u8-set! bv offset | ||
| 258 | (bitwise-merge m w v))))) | ||
| 259 | (set0! (lambda (bv offset value) | ||
| 260 | (setq! bv offset 0 5 value))) | ||
| 261 | (set1! (lambda (bv offset value) | ||
| 262 | (setq! bv offset 5 8 (bit-field value 0 3)) | ||
| 263 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 264 | (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5))))) | ||
| 265 | (set2! (lambda (bv offset value) | ||
| 266 | (setq! bv offset 2 7 value))) | ||
| 267 | (set3! (lambda (bv offset value) | ||
| 268 | (setq! bv offset 7 8 (bit-field value 0 1)) | ||
| 269 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 270 | (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5))))) | ||
| 271 | (set4! (lambda (bv offset value) | ||
| 272 | (setq! bv offset 4 8 (bit-field value 0 4)) | ||
| 273 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 274 | (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5))))) | ||
| 275 | (set5! (lambda (bv offset value) | ||
| 276 | (setq! bv offset 1 6 value))) | ||
| 277 | (set6! (lambda (bv offset value) | ||
| 278 | (setq! bv offset 6 8 (bit-field value 0 2)) | ||
| 279 | (or (= (+ 1 offset) (bytevector-length bv)) | ||
| 280 | (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5))))) | ||
| 281 | (set7! (lambda (bv offset value) | ||
| 282 | (setq! bv offset 3 8 value))) | ||
| 283 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | ||
| 284 | (lambda (bv index value) | ||
| 285 | "Set the INDEXth quintet of BV to VALUE, assuming quintets start from | ||
| 286 | the least-significant bits." | ||
| 287 | (let ((p (vector-ref sets (modulo index 8)))) | ||
| 288 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | ||
| 289 | |||
| 290 | (define (base32-string-unfold f s) | ||
| 291 | "Given procedure F which, when applied to a character, returns the | ||
| 292 | corresponding quintet, return the bytevector corresponding to string S." | ||
| 293 | (define len (string-length s)) | ||
| 294 | |||
| 295 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | ||
| 296 | (string-fold (lambda (chr index) | ||
| 297 | (bytevector-quintet-set! bv index (f chr)) | ||
| 298 | (+ 1 index)) | ||
| 299 | 0 | ||
| 300 | s) | ||
| 301 | bv)) | ||
| 302 | |||
| 303 | (define (base32-string-unfold-right f s) | ||
| 304 | "Given procedure F which, when applied to a character, returns the | ||
| 305 | corresponding quintet, return the bytevector corresponding to string S, | ||
| 306 | starting from the right of S." | ||
| 307 | (define len (string-length s)) | ||
| 308 | |||
| 309 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | ||
| 310 | (string-fold-right (lambda (chr index) | ||
| 311 | (bytevector-quintet-set-right! bv index (f chr)) | ||
| 312 | (+ 1 index)) | ||
| 313 | 0 | ||
| 314 | s) | ||
| 315 | bv)) | ||
| 316 | |||
| 317 | (define (make-base32-string->bytevector base32-string-unfold base32-chars) | ||
| 318 | (let ((char->value (let loop ((i 0) | ||
| 319 | (v vlist-null)) | ||
| 320 | (if (= i (vector-length base32-chars)) | ||
| 321 | v | ||
| 322 | (loop (+ 1 i) | ||
| 323 | (vhash-consv (vector-ref base32-chars i) | ||
| 324 | i v)))))) | ||
| 325 | (lambda (s) | ||
| 326 | "Return the binary representation of base32 string S as a bytevector." | ||
| 327 | (base32-string-unfold (lambda (chr) | ||
| 328 | (or (and=> (vhash-assv chr char->value) cdr) | ||
| 329 | (error "invalid base32 character" chr))) | ||
| 330 | s)))) | ||
| 331 | |||
| 332 | (define base32-string->bytevector | ||
| 333 | (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars)) | ||
| 334 | |||
| 335 | (define nix-base32-string->bytevector | ||
| 336 | (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars)) | ||
| 337 | |||
| 338 | |||
| 339 | |||
| 340 | ;;; | ||
| 341 | ;;; Base 16. | 79 | ;;; Base 16. |
| 342 | ;;; | 80 | ;;; |
| 343 | 81 | ||
diff --git a/tests/base32.scm b/tests/base32.scm new file mode 100644 index 00000000000..b8b9ebb0dda --- /dev/null +++ b/tests/base32.scm | |||
| @@ -0,0 +1,93 @@ | |||
| 1 | ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- | ||
| 2 | ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> | ||
| 3 | ;;; | ||
| 4 | ;;; This file is part of Guix. | ||
| 5 | ;;; | ||
| 6 | ;;; Guix is free software; you can redistribute it and/or modify it | ||
| 7 | ;;; under the terms of the GNU General Public License as published by | ||
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | ||
| 9 | ;;; your option) any later version. | ||
| 10 | ;;; | ||
| 11 | ;;; Guix is distributed in the hope that it will be useful, but | ||
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 14 | ;;; GNU General Public License for more details. | ||
| 15 | ;;; | ||
| 16 | ;;; You should have received a copy of the GNU General Public License | ||
| 17 | ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. | ||
| 18 | |||
| 19 | (define-module (test-base32) | ||
| 20 | #:use-module (guix base32) | ||
| 21 | #:use-module (guix utils) | ||
| 22 | #:use-module (srfi srfi-1) | ||
| 23 | #:use-module (srfi srfi-64) | ||
| 24 | #:use-module (ice-9 rdelim) | ||
| 25 | #:use-module (ice-9 popen) | ||
| 26 | #:use-module (rnrs bytevectors) | ||
| 27 | #:use-module (rnrs io ports)) | ||
| 28 | |||
| 29 | ;; Test the (guix base32) module. | ||
| 30 | |||
| 31 | (define %nix-hash | ||
| 32 | (or (getenv "NIX_HASH") | ||
| 33 | "nix-hash")) | ||
| 34 | |||
| 35 | (test-begin "base32") | ||
| 36 | |||
| 37 | (test-assert "bytevector->base32-string" | ||
| 38 | (fold (lambda (bv expected result) | ||
| 39 | (and result | ||
| 40 | (string=? (bytevector->base32-string bv) | ||
| 41 | expected))) | ||
| 42 | #t | ||
| 43 | |||
| 44 | ;; Examples from RFC 4648. | ||
| 45 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")) | ||
| 46 | '("" | ||
| 47 | "my" | ||
| 48 | "mzxq" | ||
| 49 | "mzxw6" | ||
| 50 | "mzxw6yq" | ||
| 51 | "mzxw6ytb" | ||
| 52 | "mzxw6ytboi"))) | ||
| 53 | |||
| 54 | (test-assert "base32-string->bytevector" | ||
| 55 | (every (lambda (bv) | ||
| 56 | (equal? (base32-string->bytevector | ||
| 57 | (bytevector->base32-string bv)) | ||
| 58 | bv)) | ||
| 59 | ;; Examples from RFC 4648. | ||
| 60 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) | ||
| 61 | |||
| 62 | (test-assert "nix-base32-string->bytevector" | ||
| 63 | (every (lambda (bv) | ||
| 64 | (equal? (nix-base32-string->bytevector | ||
| 65 | (bytevector->nix-base32-string bv)) | ||
| 66 | bv)) | ||
| 67 | ;; Examples from RFC 4648. | ||
| 68 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) | ||
| 69 | |||
| 70 | ;; The following tests requires `nix-hash' in $PATH. | ||
| 71 | (test-skip (if (false-if-exception (system* %nix-hash "--version")) | ||
| 72 | 0 | ||
| 73 | 1)) | ||
| 74 | |||
| 75 | (test-assert "sha256 & bytevector->nix-base32-string" | ||
| 76 | (let ((file (search-path %load-path "tests/test.drv"))) | ||
| 77 | (equal? (bytevector->nix-base32-string | ||
| 78 | (sha256 (call-with-input-file file get-bytevector-all))) | ||
| 79 | (let* ((c (format #f "~a --type sha256 --base32 --flat \"~a\"" | ||
| 80 | %nix-hash file)) | ||
| 81 | (p (open-input-pipe c)) | ||
| 82 | (l (read-line p))) | ||
| 83 | (close-pipe p) | ||
| 84 | l)))) | ||
| 85 | |||
| 86 | (test-end) | ||
| 87 | |||
| 88 | |||
| 89 | (exit (= (test-runner-fail-count (test-runner-current)) 0)) | ||
| 90 | |||
| 91 | ;;; Local Variables: | ||
| 92 | ;;; eval: (put 'test-assert 'scheme-indent-function 1) | ||
| 93 | ;;; End: | ||
diff --git a/tests/builders.scm b/tests/builders.scm index 8b0fa117a91..d9dc5afa204 100644 --- a/tests/builders.scm +++ b/tests/builders.scm | |||
| @@ -23,6 +23,7 @@ | |||
| 23 | #:use-module (guix build-system gnu) | 23 | #:use-module (guix build-system gnu) |
| 24 | #:use-module (guix store) | 24 | #:use-module (guix store) |
| 25 | #:use-module (guix utils) | 25 | #:use-module (guix utils) |
| 26 | #:use-module (guix base32) | ||
| 26 | #:use-module (guix derivations) | 27 | #:use-module (guix derivations) |
| 27 | #:use-module ((guix packages) #:select (package-derivation)) | 28 | #:use-module ((guix packages) #:select (package-derivation)) |
| 28 | #:use-module (distro packages bootstrap) | 29 | #:use-module (distro packages bootstrap) |
diff --git a/tests/derivations.scm b/tests/derivations.scm index 01ede11af09..618a7c4b960 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm | |||
| @@ -21,6 +21,7 @@ | |||
| 21 | #:use-module (guix derivations) | 21 | #:use-module (guix derivations) |
| 22 | #:use-module (guix store) | 22 | #:use-module (guix store) |
| 23 | #:use-module (guix utils) | 23 | #:use-module (guix utils) |
| 24 | #:use-module (guix base32) | ||
| 24 | #:use-module ((guix packages) #:select (package-derivation)) | 25 | #:use-module ((guix packages) #:select (package-derivation)) |
| 25 | #:use-module (distro packages bootstrap) | 26 | #:use-module (distro packages bootstrap) |
| 26 | #:use-module (srfi srfi-1) | 27 | #:use-module (srfi srfi-1) |
diff --git a/tests/utils.scm b/tests/utils.scm index 1ced410d419..0a6e8a08332 100644 --- a/tests/utils.scm +++ b/tests/utils.scm | |||
| @@ -16,59 +16,17 @@ | |||
| 16 | ;;; You should have received a copy of the GNU General Public License | 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. | 17 | ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | 18 | ||
| 19 | |||
| 20 | (define-module (test-utils) | 19 | (define-module (test-utils) |
| 21 | #:use-module (guix utils) | 20 | #:use-module (guix utils) |
| 22 | #:use-module ((guix store) #:select (store-path-package-name)) | 21 | #:use-module ((guix store) #:select (store-path-package-name)) |
| 23 | #:use-module (srfi srfi-1) | 22 | #:use-module (srfi srfi-1) |
| 24 | #:use-module (srfi srfi-11) | 23 | #:use-module (srfi srfi-11) |
| 25 | #:use-module (srfi srfi-26) | ||
| 26 | #:use-module (srfi srfi-64) | 24 | #:use-module (srfi srfi-64) |
| 27 | #:use-module (rnrs bytevectors) | 25 | #:use-module (rnrs bytevectors) |
| 28 | #:use-module (rnrs io ports) | ||
| 29 | #:use-module (ice-9 rdelim) | ||
| 30 | #:use-module (ice-9 popen) | ||
| 31 | #:use-module (ice-9 match)) | 26 | #:use-module (ice-9 match)) |
| 32 | 27 | ||
| 33 | (define %nix-hash | ||
| 34 | (or (getenv "NIX_HASH") | ||
| 35 | "nix-hash")) | ||
| 36 | |||
| 37 | (test-begin "utils") | 28 | (test-begin "utils") |
| 38 | 29 | ||
| 39 | (test-assert "bytevector->base32-string" | ||
| 40 | (fold (lambda (bv expected result) | ||
| 41 | (and result | ||
| 42 | (string=? (bytevector->base32-string bv) | ||
| 43 | expected))) | ||
| 44 | #t | ||
| 45 | |||
| 46 | ;; Examples from RFC 4648. | ||
| 47 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")) | ||
| 48 | '("" | ||
| 49 | "my" | ||
| 50 | "mzxq" | ||
| 51 | "mzxw6" | ||
| 52 | "mzxw6yq" | ||
| 53 | "mzxw6ytb" | ||
| 54 | "mzxw6ytboi"))) | ||
| 55 | |||
| 56 | (test-assert "base32-string->bytevector" | ||
| 57 | (every (lambda (bv) | ||
| 58 | (equal? (base32-string->bytevector | ||
| 59 | (bytevector->base32-string bv)) | ||
| 60 | bv)) | ||
| 61 | ;; Examples from RFC 4648. | ||
| 62 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) | ||
| 63 | |||
| 64 | (test-assert "nix-base32-string->bytevector" | ||
| 65 | (every (lambda (bv) | ||
| 66 | (equal? (nix-base32-string->bytevector | ||
| 67 | (bytevector->nix-base32-string bv)) | ||
| 68 | bv)) | ||
| 69 | ;; Examples from RFC 4648. | ||
| 70 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) | ||
| 71 | |||
| 72 | (test-assert "bytevector->base16-string->bytevector" | 30 | (test-assert "bytevector->base16-string->bytevector" |
| 73 | (every (lambda (bv) | 31 | (every (lambda (bv) |
| 74 | (equal? (base16-string->bytevector | 32 | (equal? (base16-string->bytevector |
| @@ -76,22 +34,6 @@ | |||
| 76 | bv)) | 34 | bv)) |
| 77 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) | 35 | (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) |
| 78 | 36 | ||
| 79 | ;; The following tests requires `nix-hash' in $PATH. | ||
| 80 | (test-skip (if (false-if-exception (system* %nix-hash "--version")) | ||
| 81 | 0 | ||
| 82 | 1)) | ||
| 83 | |||
| 84 | (test-assert "sha256 & bytevector->nix-base32-string" | ||
| 85 | (let ((file (search-path %load-path "tests/test.drv"))) | ||
| 86 | (equal? (bytevector->nix-base32-string | ||
| 87 | (sha256 (call-with-input-file file get-bytevector-all))) | ||
| 88 | (let* ((c (format #f "~a --type sha256 --base32 --flat \"~a\"" | ||
| 89 | %nix-hash file)) | ||
| 90 | (p (open-input-pipe c)) | ||
| 91 | (l (read-line p))) | ||
| 92 | (close-pipe p) | ||
| 93 | l)))) | ||
| 94 | |||
| 95 | (test-assert "gnu-triplet->nix-system" | 37 | (test-assert "gnu-triplet->nix-system" |
| 96 | (let ((samples '(("i586-gnu0.3" "i686-gnu") | 38 | (let ((samples '(("i586-gnu0.3" "i686-gnu") |
| 97 | ("x86_64-unknown-linux-gnu" "x86_64-linux") | 39 | ("x86_64-unknown-linux-gnu" "x86_64-linux") |
