diff options
| -rw-r--r-- | module/util/base64.scm | 144 | ||||
| -rw-r--r-- | tests/base64.scm | 19 |
2 files changed, 163 insertions, 0 deletions
diff --git a/module/util/base64.scm b/module/util/base64.scm new file mode 100644 index 00000000..2a49ba1e --- /dev/null +++ b/module/util/base64.scm @@ -0,0 +1,144 @@ +(define-module (util base64) + :use-module (util) + :use-module ((rnrs bytevectors) + :select (bytevector-u8-ref + bytevector-u8-set! + bytevector-length + make-bytevector)) + :use-module ((rnrs io ports) + :select (string->bytevector + bytevector->string + make-transcoder + latin-1-codec + native-transcoder))) + +(define table + (list->vector + (map char->integer + (string->list + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")))) + +(define (real->encoded byte) + (vector-ref table byte)) + +(define (encoded->real byte) + (define A (char->integer #\A)) + (define Z (char->integer #\Z)) + (define a (char->integer #\a)) + (define z (char->integer #\z)) + (define zero (char->integer #\0)) + (define nine (char->integer #\9)) + (cond [(= byte (char->integer #\=)) 0] + [(= byte (char->integer #\+)) 62] + [(= byte (char->integer #\/)) 63] + [(<= A byte Z) + (- byte A)] + [(<= a byte z) + (+ 26 (- byte a))] + [(<= zero byte nine) + (+ 26 26 (- byte zero))] + [else (error "Invalid encoded value" byte (integer->char byte))])) + +(define ref + (make-procedure-with-setter + bytevector-u8-ref + bytevector-u8-set!)) + +(define-public (base64->bytevector bv) + (let ((len* (bytevector-length bv))) + (if (zero? len*) + (make-bytevector 0) + (let* ((rest (+ (if (= (char->integer #\=) (ref bv (- len* 1))) + 1 0) + (if (= (char->integer #\=) (ref bv (- len* 2))) + 1 0))) + (x (/ (- len* rest) 4)) + (ret-len (floor (* 3 x)))) + + (define ret (make-bytevector ret-len)) + + (do ((i 0 (1+ i))) + ((>= i (floor x))) + (let ((a (encoded->real (ref bv (+ (* i 4) 0)))) + (b (encoded->real (ref bv (+ (* i 4) 1)))) + (c (encoded->real (ref bv (+ (* i 4) 2)))) + (d (encoded->real (ref bv (+ (* i 4) 3))))) + (let ((aa (logior (ash a 2) (ash b -4))) + (ab (logior (ash (logand b #xF) 4) (ash c -2))) + (ac (logior (ash (logand c 3) 6) d))) + + (set! (ref ret (+ (* i 3) 0)) aa + (ref ret (+ (* i 3) 1)) ab + (ref ret (+ (* i 3) 2)) ac)))) + + + (case rest + [(2) + (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0)))) + (b (encoded->real (ref bv (+ (* (floor x) 4) 1))))) + (let ((aa (logior (ash a 2) (ash b -4)))) + (set! (ref ret (- ret-len 1)) aa)))] + [(1) + (let ((a (encoded->real (ref bv (+ (* (floor x) 4) 0)))) + (b (encoded->real (ref bv (+ (* (floor x) 4) 1)))) + (c (encoded->real (ref bv (+ (* (floor x) 4) 2))))) + (let ((aa (logior (ash a 2) (ash b -4))) + (ab (logior (ash (logand b #xF) 4) (ash c -2)))) + (set! (ref ret (- ret-len 2)) aa + (ref ret (- ret-len 1)) ab)))]) + + ret)))) + +(define-public (bytevector->base64 bv) + (let* ((len (bytevector-length bv)) + (iterations rest (floor/ len 3))) + (define ret (make-bytevector (+ (* 4 iterations) + (if (zero? rest) + 0 4)))) + + (do ((i 0 (1+ i))) + ((>= i iterations)) + (let ((a (ref bv (+ (* i 3) 0))) + (b (ref bv (+ (* i 3) 1))) + (c (ref bv (+ (* i 3) 2)))) + (let ((aa (ash a -2)) + (ab (logior (ash (logand #b11 a) 4) (ash b -4))) + (ac (logior (ash (logand b #b1111) 2) (ash c -6))) + (ad (logand c #x3F))) + (set! (ref ret (+ (* i 4) 0)) (real->encoded aa) + (ref ret (+ (* i 4) 1)) (real->encoded ab) + (ref ret (+ (* i 4) 2)) (real->encoded ac) + (ref ret (+ (* i 4) 3)) (real->encoded ad))))) + + (case rest + [(1) + (let ((byte (ref bv (- len 1)))) + (let ((a (ash byte -2)) + (b (ash (logand byte 3) 4))) + (set! (ref ret (+ 0 (* 4 iterations))) (real->encoded a) + (ref ret (+ 1 (* 4 iterations))) (real->encoded b) + (ref ret (+ 2 (* 4 iterations))) (char->integer #\=) + (ref ret (+ 3 (* 4 iterations))) (char->integer #\=))))] + [(2) + (let ((byte1 (ref bv (- len 2))) + (byte2 (ref bv (- len 1)))) + (let ((a (ash byte1 -2)) + (b (logior (ash (logand byte1 3) 4) (ash byte2 -4 ))) + (c (ash (logand byte2 #xF) 2))) + (set! (ref ret (+ 0 (* 4 iterations))) (real->encoded a) + (ref ret (+ 1 (* 4 iterations))) (real->encoded b) + (ref ret (+ 2 (* 4 iterations))) (real->encoded c) + (ref ret (+ 3 (* 4 iterations))) (char->integer #\=))))]) + + ret)) + +(define*-public (base64encode string optional: (transcoder (native-transcoder))) + (bytevector->string + (bytevector->base64 (string->bytevector string transcoder)) + (make-transcoder (latin-1-codec)))) + +(define*-public (base64decode string optional: (transcoder (native-transcoder))) + (bytevector->string + (base64->bytevector + (string->bytevector string (make-transcoder (latin-1-codec)))) + transcoder)) diff --git a/tests/base64.scm b/tests/base64.scm new file mode 100644 index 00000000..6b862a38 --- /dev/null +++ b/tests/base64.scm @@ -0,0 +1,19 @@ +(((util base64) base64encode base64decode)) + +;; Examples from RFC4648 + +(test-equal "" (base64encode "")) +(test-equal "Zg==" (base64encode "f")) +(test-equal "Zm8=" (base64encode "fo")) +(test-equal "Zm9v" (base64encode "foo")) +(test-equal "Zm9vYg==" (base64encode "foob")) +(test-equal "Zm9vYmE=" (base64encode "fooba")) +(test-equal "Zm9vYmFy" (base64encode "foobar")) + +(test-equal "" (base64decode "")) +(test-equal "f" (base64decode "Zg==")) +(test-equal "fo" (base64decode "Zm8=")) +(test-equal "foo" (base64decode "Zm9v")) +(test-equal "foob" (base64decode "Zm9vYg==")) +(test-equal "fooba" (base64decode "Zm9vYmE=")) +(test-equal "foobar" (base64decode "Zm9vYmFy")) |