aliens/tekuti
1
0
Fork 0
Code Activity

port (tekuti base64) to use (rnrs bytevectors)

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-10-14 11:42:25 +02:00
parent 97a49f0801
commit 1b9e370805
2 changed files with 93 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

152
tekuti/base64.scm
View file

@ -1,5 +1,6 @@
;; Tekuti ;; Tekuti
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com> ;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com>
;; Copyright (C) 2009 Andreas Rottmann <a dot rottmann at gmx dot at>
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as ;; modify it under the terms of the GNU General Public License as
@ -25,86 +26,113 @@
;;; Code: ;;; Code:
(define-module (tekuti base64) (define-module (tekuti base64)
#:use-module (rnrs bytevectors)
#:export (base64-encode base64-decode)) #:export (base64-encode base64-decode))
(define b64-chars (define b64-bytes
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwzyz0123456789+/") (string->utf8
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwzyz0123456789+/"))
(define (int->b64-char i) (define (int->b64-byte i)
(string-ref b64-chars (logand i 63))) (bytevector-u8-ref b64-bytes (logand i 63)))
(define b64-char-ranges (define b64-byte-ranges
(map cons (map cons
(map char->integer '(#\A #\a #\0 #\+ #\/)) (map char->integer '(#\A #\a #\0 #\+ #\/))
(map char->integer '(#\Z #\z #\9 #\+ #\/)))) (map char->integer '(#\Z #\z #\9 #\+ #\/))))
(define (b64-char->int c) (define (b64-byte->int i)
(let ((i (char->integer c))) (let lp ((ranges b64-byte-ranges) (out 0))
(let lp ((ranges b64-char-ranges) (out 0)) (cond ((null? ranges)
(cond ((null? ranges) (error "bad base64 byte" i))
(error "bad base64 char" c)) ((and (>= i (caar ranges)) (<= i (cdar ranges)))
((and (>= i (caar ranges)) (<= i (cdar ranges))) (+ out (- i (caar ranges))))
(+ out (- i (caar ranges)))) (else
(else (lp (cdr ranges) (+ out (+ 1 (- (cdar ranges)
(lp (cdr ranges) (+ out (1+ (- (cdar ranges) (caar ranges)))))))))
(caar ranges))))))))))
(define make-bytevector make-string) (define (bytevector-pad bv n fill)
(define bytevector-ref string-ref) (let ((result (make-bytevector n fill)))
(define bytevector-length string-length) (bytevector-copy! bv 0 result 0 (bytevector-length bv))
(define bytevector-set! string-set!) result))
(define bytevector-pad string-pad-right)
(define byte->integer char->integer)
(define integer->byte integer->char)
(define-macro (bytevector-map-n-to-m n m) (define-syntax bytevector-map-n-to-m
`(lambda (proc s) (lambda (stx)
(let* ((len (bytevector-length s)) (syntax-case stx ()
(out (make-bytevector (* len (/ ,m ,n))))) ((_ n m)
(let lp ((i 0) (j 0)) (with-syntax (((byte-arg ...)
(cond (map (lambda (x)
((< i len) #`(bytevector-u8-ref s (+ i #,x)))
(let inner ((k 0) (bytes (proc ,@(map (lambda (x) (iota (syntax->datum #'n)))))
`(bytevector-ref s (+ i ,x))) #'(lambda (proc s)
(iota n))))) (let* ((len (bytevector-length s))
(if (not (null? bytes)) (out (make-bytevector (* len (/ m n)))))
(begin (bytevector-set! out (+ j k) (car bytes)) (let lp ((i 0) (j 0))
(inner (1+ k) (cdr bytes))))) (cond
(lp (+ i ,n) (+ j ,m))) ((< i len)
(else out)))))) (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 (define bytevector-map-3-to-4
(bytevector-map-n-to-m 3 4)) (bytevector-map-n-to-m 3 4))
(define bytevector-map-4-to-3 (define bytevector-map-4-to-3
(bytevector-map-n-to-m 4 3)) (bytevector-map-n-to-m 4 3))
(define (base64-encode s) (define (bytevector-fill-range! bv start end u8)
(let* ((npad (remainder (- 3 (remainder (bytevector-length s) 3)) 3)) (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 (out (bytevector-map-3-to-4
(lambda (x y z) (lambda (x y z)
(let ((n (logior (ash (byte->integer x) 16) (let ((n (logior (ash x 16) (ash y 8) z)))
(ash (byte->integer y) 8) (map int->b64-byte
(byte->integer z))))
(map int->b64-char
(list (ash n -18) (ash n -12) (ash n -6) n)))) (list (ash n -18) (ash n -12) (ash n -6) n))))
(bytevector-pad s (+ (bytevector-length s) npad) (bytevector-pad bv (+ (bytevector-length bv) npad) 0))))
(integer->byte 0))))) (bytevector-fill-range! out
(string-append (substring out 0 (- (string-length out) npad)) (- (bytevector-length out) npad)
(make-string npad #\=)))) (bytevector-length out)
(char->integer #\=))
(utf8->string out)))
(define (base64-decode s) (define eql-byte (char->integer #\=))
(let* ((npad (cond ((string-suffix? "==" s) 2)
((string-suffix? "=" s) 1) (define (b64-bv-npad bv)
(else 0))) (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 str)
(let* ((bv (string->utf8 str))
(npad (b64-bv-npad bv))
(out (bytevector-map-4-to-3 (out (bytevector-map-4-to-3
(lambda (w x y z) (lambda (w x y z)
(let ((n (logior (ash (b64-char->int w) 18) (let ((n (logior (ash (b64-byte->int w) 18)
(ash (b64-char->int x) 12) (ash (b64-byte->int x) 12)
(ash (b64-char->int y) 6) (ash (b64-byte->int y) 6)
(b64-char->int z)))) (b64-byte->int z))))
(map integer->byte (list (ash n -16) (logand (ash n -8) 255)
(list (ash n -16) (logand (ash n -8) 255) (logand n 255))))
(logand n 255))))) (bytevector-copy/padding bv npad (char->integer #\A))))
(string-append (substring s 0 (- (string-length s) npad)) (result (make-bytevector (- (bytevector-length out) npad))))
(make-string npad #\A))))) (bytevector-copy! out 0 result 0 (bytevector-length result))
(substring out 0 (- (string-length out) npad)))) result))

4
tekuti/request.scm
View file

@ -32,6 +32,7 @@
#:use-module (tekuti url) #:use-module (tekuti url)
#:use-module (tekuti config) #:use-module (tekuti config)
#:use-module (tekuti base64) #:use-module (tekuti base64)
#:use-module (rnrs bytevectors)
#:export (make-request rcons rcons* rpush rpush* rref let-request #:export (make-request rcons rcons* rpush rpush* rref let-request
request-path-case request-authenticated? request-path-case request-authenticated?
request-form-data request-server-name)) request-form-data request-server-name))
@ -122,7 +123,8 @@
(and auth (and auth
(match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64) (match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64)
(match-bind "^([^:]*):(.*)$" (match-bind "^([^:]*):(.*)$"
(base64-decode b64) (_ user pass) (utf8->string (base64-decode b64))
(_ user pass)
(and (equal? user *admin-user*) (and (equal? user *admin-user*)
(equal? pass *admin-pass*)) (equal? pass *admin-pass*))
#f) #f)