diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-23 04:56:49 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-23 04:56:49 +0200 |
| commit | 6f9c6298b3b61642e4acaca6c7ad33943c9f4ab3 (patch) | |
| tree | 59a6fd5c5eba65e97837c9a6e0240313a7eed098 /module/base64.scm | |
| parent | Minor cleanup of entry-points/server. (diff) | |
| download | calp-6f9c6298b3b61642e4acaca6c7ad33943c9f4ab3.tar.gz calp-6f9c6298b3b61642e4acaca6c7ad33943c9f4ab3.tar.xz | |
Normalize base64 errors.
Diffstat (limited to 'module/base64.scm')
| -rw-r--r-- | module/base64.scm | 91 |
1 files changed, 49 insertions, 42 deletions
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)) |