From 6f9c6298b3b61642e4acaca6c7ad33943c9f4ab3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 23 Jun 2022 04:56:49 +0200 Subject: Normalize base64 errors. --- doc/ref/guile/base64.texi | 2 ++ module/base64.scm | 91 +++++++++++++++++++++++++---------------------- tests/test/base64.scm | 4 +-- 3 files changed, 52 insertions(+), 45 deletions(-) diff --git a/doc/ref/guile/base64.texi b/doc/ref/guile/base64.texi index ef262ab5..ab6bba81 100644 --- a/doc/ref/guile/base64.texi +++ b/doc/ref/guile/base64.texi @@ -5,6 +5,8 @@ @defunx bytevector->base64 bv Base procedure for all Base64 operations. Takes and returns bytevectors. + +Throws @code{decoding-error} on invalid input. @end defun @defun base64-string->bytevector string diff --git a/module/base64.scm b/module/base64.scm index 6a3d4706..e9dc9357 100644 --- a/module/base64.scm +++ b/module/base64.scm @@ -56,48 +56,55 @@ bytevector-u8-set!)) (define (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)))) + (catch 'out-of-range + (lambda () + (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)))) + (lambda (err proc fmt args data) + (scm-error 'decoding-error "base64->bytevector" + (format #f "~~a in ~~a: ~a" fmt) + (cons* err (or proc "unknown function") args) + data)))) (define (bytevector->base64 bv) (let* ((len (bytevector-length bv)) diff --git a/tests/test/base64.scm b/tests/test/base64.scm index 788e7093..61ac8856 100644 --- a/tests/test/base64.scm +++ b/tests/test/base64.scm @@ -28,14 +28,12 @@ ;; Other tests -;; TODO normalize base64 errors - (test-error "Invalid base64" 'decoding-error (base64decode "@@@@")) (test-error "To short base64" - 'out-of-range + 'decoding-error (base64decode "=")) (test-equal "AAECAw==" (bytevector->base64-string #vu8(0 1 2 3))) -- cgit v1.2.3