From b866096e7a84f59b33b90fc2e7875e2969b05df2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 23 Aug 2020 16:31:55 +0200 Subject: Base64 now free floating top level. --- module/base64.scm | 157 ++++++++++++++++++++++++++++++++++++++ module/html/util.scm | 3 +- module/util/base64.scm | 156 ------------------------------------- module/vcomponent/ical/types.scm | 2 +- module/vcomponent/parse/types.scm | 2 +- module/vcomponent/xcal/parse.scm | 2 +- tests/base64.scm | 2 +- 7 files changed, 162 insertions(+), 162 deletions(-) create mode 100644 module/base64.scm delete mode 100644 module/util/base64.scm diff --git a/module/base64.scm b/module/base64.scm new file mode 100644 index 00000000..594edf1f --- /dev/null +++ b/module/base64.scm @@ -0,0 +1,157 @@ +(define-module (base64) + :use-module ((ice-9 optargs) :select (define*-public)) + :use-module ((srfi srfi-71) :select (let*)) + :use-module (srfi srfi-88) ; suffix keywords + :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) + (set! (ref ret (+ (* i 3) 1)) ab) + (set! (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) + (set! (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)) + (set! (ref ret (+ (* i 4) 1)) (real->encoded ab)) + (set! (ref ret (+ (* i 4) 2)) (real->encoded ac)) + (set! (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)) + (set! (ref ret (+ 1 (* 4 iterations))) (real->encoded b)) + (set! (ref ret (+ 2 (* 4 iterations))) (char->integer #\=)) + (set! (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)) + (set! (ref ret (+ 1 (* 4 iterations))) (real->encoded b)) + (set! (ref ret (+ 2 (* 4 iterations))) (real->encoded c)) + (set! (ref ret (+ 3 (* 4 iterations))) (char->integer #\=))))]) + + ret)) + +;; string -> bv +(define-public (base64-string->bytevector string) + (base64->bytevector + (string->bytevector string (make-transcoder (latin-1-codec))))) + +;; bv -> string +(define-public (bytevector->base64-string bv) + (bytevector->string (bytevector->base64 bv) + (make-transcoder (latin-1-codec)))) + +;; string -> string +(define*-public (base64encode string optional: (transcoder (native-transcoder))) + (bytevector->string + (bytevector->base64 (string->bytevector string transcoder)) + (make-transcoder (latin-1-codec)))) + +;; string -> string +(define*-public (base64decode string optional: (transcoder (native-transcoder))) + (bytevector->string + (base64->bytevector + (string->bytevector string (make-transcoder (latin-1-codec)))) + transcoder)) diff --git a/module/html/util.scm b/module/html/util.scm index c9252122..4e15356a 100644 --- a/module/html/util.scm +++ b/module/html/util.scm @@ -1,6 +1,5 @@ (define-module (html util) - :use-module ((util base64) - :select (base64encode base64decode)) + :use-module ((base64) :select (base64encode base64decode)) :use-module (util)) ;;; @var{html-attr} & @var{html-unattr} used to just strip any diff --git a/module/util/base64.scm b/module/util/base64.scm deleted file mode 100644 index 148055c9..00000000 --- a/module/util/base64.scm +++ /dev/null @@ -1,156 +0,0 @@ -(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)) - -;; string -> bv -(define-public (base64-string->bytevector string) - (base64->bytevector - (string->bytevector string (make-transcoder (latin-1-codec))))) - -;; bv -> string -(define-public (bytevector->base64-string bv) - (bytevector->string (bytevector->base64 bv) - (make-transcoder (latin-1-codec)))) - -;; string -> string -(define*-public (base64encode string optional: (transcoder (native-transcoder))) - (bytevector->string - (bytevector->base64 (string->bytevector string transcoder)) - (make-transcoder (latin-1-codec)))) - -;; string -> string -(define*-public (base64decode string optional: (transcoder (native-transcoder))) - (bytevector->string - (base64->bytevector - (string->bytevector string (make-transcoder (latin-1-codec)))) - transcoder)) diff --git a/module/vcomponent/ical/types.scm b/module/vcomponent/ical/types.scm index f2787693..b46bb236 100644 --- a/module/vcomponent/ical/types.scm +++ b/module/vcomponent/ical/types.scm @@ -2,7 +2,7 @@ (define-module (vcomponent ical types) :use-module (util) :use-module (util exceptions) - :use-module (util base64) + :use-module (base64) :use-module (datetime)) diff --git a/module/vcomponent/parse/types.scm b/module/vcomponent/parse/types.scm index 3ae3a74a..c12da750 100644 --- a/module/vcomponent/parse/types.scm +++ b/module/vcomponent/parse/types.scm @@ -1,7 +1,7 @@ (define-module (vcomponent parse types) :use-module (util) :use-module (util exceptions) - :use-module (util base64) + :use-module (base64) :use-module (datetime) :use-module (srfi srfi-9 gnu) ) diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm index 16e47e6f..a4b51b5b 100644 --- a/module/vcomponent/xcal/parse.scm +++ b/module/vcomponent/xcal/parse.scm @@ -1,7 +1,7 @@ (define-module (vcomponent xcal parse) :use-module (util) :use-module (util exceptions) - :use-module (util base64) + :use-module (base64) :use-module (ice-9 match) :use-module (sxml match) :use-module (vcomponent) diff --git a/tests/base64.scm b/tests/base64.scm index 6b862a38..b0bb992a 100644 --- a/tests/base64.scm +++ b/tests/base64.scm @@ -1,4 +1,4 @@ -(((util base64) base64encode base64decode)) +(((base64) base64encode base64decode)) ;; Examples from RFC4648 -- cgit v1.2.3