From 1b9e3708053491a24bda0ab3ef7310a07c895ddc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Oct 2010 11:42:25 +0200 Subject: port (tekuti base64) to use (rnrs bytevectors) * tekuti/base64.scm: Port to (rnrs bytevectors). All the real work was done by Andreas Rottmann. * tekuti/request.scm (request-authenticated?): Run the decoded user name and password bytevector through utf8->string. --- tekuti/base64.scm | 152 +++++++++++++++++++++++++++++++---------------------- tekuti/request.scm | 4 +- 2 files changed, 93 insertions(+), 63 deletions(-) diff --git a/tekuti/base64.scm b/tekuti/base64.scm index bde9c91..a971e5e 100644 --- a/tekuti/base64.scm +++ b/tekuti/base64.scm @@ -1,5 +1,6 @@ ;; Tekuti -;; Copyright (C) 2008 Andy Wingo +;; Copyright (C) 2008, 2010 Andy Wingo +;; Copyright (C) 2009 Andreas Rottmann ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -25,86 +26,113 @@ ;;; Code: (define-module (tekuti base64) + #:use-module (rnrs bytevectors) #:export (base64-encode base64-decode)) -(define b64-chars - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwzyz0123456789+/") +(define b64-bytes + (string->utf8 + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwzyz0123456789+/")) -(define (int->b64-char i) - (string-ref b64-chars (logand i 63))) +(define (int->b64-byte i) + (bytevector-u8-ref b64-bytes (logand i 63))) -(define b64-char-ranges +(define b64-byte-ranges (map cons (map char->integer '(#\A #\a #\0 #\+ #\/)) (map char->integer '(#\Z #\z #\9 #\+ #\/)))) -(define (b64-char->int c) - (let ((i (char->integer c))) - (let lp ((ranges b64-char-ranges) (out 0)) - (cond ((null? ranges) - (error "bad base64 char" c)) - ((and (>= i (caar ranges)) (<= i (cdar ranges))) - (+ out (- i (caar ranges)))) - (else - (lp (cdr ranges) (+ out (1+ (- (cdar ranges) - (caar ranges)))))))))) +(define (b64-byte->int i) + (let lp ((ranges b64-byte-ranges) (out 0)) + (cond ((null? ranges) + (error "bad base64 byte" i)) + ((and (>= i (caar ranges)) (<= i (cdar ranges))) + (+ out (- i (caar ranges)))) + (else + (lp (cdr ranges) (+ out (+ 1 (- (cdar ranges) + (caar ranges))))))))) -(define make-bytevector make-string) -(define bytevector-ref string-ref) -(define bytevector-length string-length) -(define bytevector-set! string-set!) -(define bytevector-pad string-pad-right) -(define byte->integer char->integer) -(define integer->byte integer->char) +(define (bytevector-pad bv n fill) + (let ((result (make-bytevector n fill))) + (bytevector-copy! bv 0 result 0 (bytevector-length bv)) + result)) -(define-macro (bytevector-map-n-to-m n m) - `(lambda (proc s) - (let* ((len (bytevector-length s)) - (out (make-bytevector (* len (/ ,m ,n))))) - (let lp ((i 0) (j 0)) - (cond - ((< i len) - (let inner ((k 0) (bytes (proc ,@(map (lambda (x) - `(bytevector-ref s (+ i ,x))) - (iota n))))) - (if (not (null? bytes)) - (begin (bytevector-set! out (+ j k) (car bytes)) - (inner (1+ k) (cdr bytes))))) - (lp (+ i ,n) (+ j ,m))) - (else out)))))) +(define-syntax bytevector-map-n-to-m + (lambda (stx) + (syntax-case stx () + ((_ n m) + (with-syntax (((byte-arg ...) + (map (lambda (x) + #`(bytevector-u8-ref s (+ i #,x))) + (iota (syntax->datum #'n))))) + #'(lambda (proc s) + (let* ((len (bytevector-length s)) + (out (make-bytevector (* len (/ m n))))) + (let lp ((i 0) (j 0)) + (cond + ((< i len) + (let inner ((k 0) (bytes (proc byte-arg ...))) + (if (not (null? bytes)) + (begin (bytevector-u8-set! out (+ j k) (car bytes)) + (inner (+ k 1) (cdr bytes))))) + (lp (+ i n) (+ j m))) + (else out)))))))))) (define bytevector-map-3-to-4 (bytevector-map-n-to-m 3 4)) (define bytevector-map-4-to-3 (bytevector-map-n-to-m 4 3)) -(define (base64-encode s) - (let* ((npad (remainder (- 3 (remainder (bytevector-length s) 3)) 3)) +(define (bytevector-fill-range! bv start end u8) + (do ((i (- end 1) (- i 1))) + ((< i start)) + (bytevector-u8-set! bv i u8))) + +(define (bytevector-copy/padding bv npad pad-byte) + (let ((result (bytevector-copy bv)) + (len (bytevector-length bv))) + (bytevector-fill-range! result (- len npad) len pad-byte) + result)) + +(define (base64-encode bv) + (let* ((npad (remainder (- 3 (remainder (bytevector-length bv) 3)) 3)) (out (bytevector-map-3-to-4 (lambda (x y z) - (let ((n (logior (ash (byte->integer x) 16) - (ash (byte->integer y) 8) - (byte->integer z)))) - (map int->b64-char + (let ((n (logior (ash x 16) (ash y 8) z))) + (map int->b64-byte (list (ash n -18) (ash n -12) (ash n -6) n)))) - (bytevector-pad s (+ (bytevector-length s) npad) - (integer->byte 0))))) - (string-append (substring out 0 (- (string-length out) npad)) - (make-string npad #\=)))) + (bytevector-pad bv (+ (bytevector-length bv) npad) 0)))) + (bytevector-fill-range! out + (- (bytevector-length out) npad) + (bytevector-length out) + (char->integer #\=)) + (utf8->string out))) + +(define eql-byte (char->integer #\=)) + +(define (b64-bv-npad bv) + (let ((len (bytevector-length bv))) + (if (> len 0) + (if (= (bytevector-u8-ref bv (- len 1)) eql-byte) + (if (> len 1) + (if (= (bytevector-u8-ref bv (- len 2)) eql-byte) + 2 + 1) + 1) + 0) + 0))) -(define (base64-decode s) - (let* ((npad (cond ((string-suffix? "==" s) 2) - ((string-suffix? "=" s) 1) - (else 0))) +(define (base64-decode str) + (let* ((bv (string->utf8 str)) + (npad (b64-bv-npad bv)) (out (bytevector-map-4-to-3 (lambda (w x y z) - (let ((n (logior (ash (b64-char->int w) 18) - (ash (b64-char->int x) 12) - (ash (b64-char->int y) 6) - (b64-char->int z)))) - (map integer->byte - (list (ash n -16) (logand (ash n -8) 255) - (logand n 255))))) - (string-append (substring s 0 (- (string-length s) npad)) - (make-string npad #\A))))) - (substring out 0 (- (string-length out) npad)))) + (let ((n (logior (ash (b64-byte->int w) 18) + (ash (b64-byte->int x) 12) + (ash (b64-byte->int y) 6) + (b64-byte->int z)))) + (list (ash n -16) (logand (ash n -8) 255) + (logand n 255)))) + (bytevector-copy/padding bv npad (char->integer #\A)))) + (result (make-bytevector (- (bytevector-length out) npad)))) + (bytevector-copy! out 0 result 0 (bytevector-length result)) + result)) diff --git a/tekuti/request.scm b/tekuti/request.scm index 4080772..536798a 100644 --- a/tekuti/request.scm +++ b/tekuti/request.scm @@ -32,6 +32,7 @@ #:use-module (tekuti url) #:use-module (tekuti config) #:use-module (tekuti base64) + #:use-module (rnrs bytevectors) #:export (make-request rcons rcons* rpush rpush* rref let-request request-path-case request-authenticated? request-form-data request-server-name)) @@ -122,7 +123,8 @@ (and auth (match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64) (match-bind "^([^:]*):(.*)$" - (base64-decode b64) (_ user pass) + (utf8->string (base64-decode b64)) + (_ user pass) (and (equal? user *admin-user*) (equal? pass *admin-pass*)) #f) -- cgit v1.2.3-54-g00ecf