aliens/tekuti
1
0
Fork 0
Code Activity

fixes due to (web http) updates

Browse source
This commit is contained in:
Aleix Conchillo Flaque 2011-01-11 16:17:58 +01:00 committed by Andy Wingo
parent a357b2a0dc
commit 2a87435f81
2 changed files with 15 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
tekuti/page-helpers.scm
View file

@ -82,8 +82,8 @@
last-modified last-modified
etag etag
(doctype xhtml-doctype) (doctype xhtml-doctype)
(content-type-params '(("charset" . "utf-8"))) (content-type-params '((charset . "utf-8")))
(content-type "text/html") (content-type 'text/html)
(extra-headers '()) (extra-headers '())
(sxml (and body (templatize #:title title #:body body)))) (sxml (and body (templatize #:title title #:body body))))
(values (build-response (values (build-response
@ -378,9 +378,10 @@
(define (with-authentication request thunk) (define (with-authentication request thunk)
(if (request-authenticated? request) (if (request-authenticated? request)
(thunk) (thunk)
(respond `((p "Authentication required, yo")) (let ((header (parse-header 'www-authenticate "Basic realm=\"Tekuti\"")))
#:status 401 (respond `((p "Authentication required, yo"))
#:extra-headers '((www-authenticate . "Basic realm=\"Tekuti\""))))) #:status 401
#:extra-headers `((www-authenticate . ,header))))))
(define (atom-header last-modified) (define (atom-header last-modified)
(define (relurl . tail) (define (relurl . tail)

20
tekuti/request.scm
View file

@ -47,9 +47,9 @@
(lambda (piece) (lambda (piece)
(let ((equals (string-index piece #\=))) (let ((equals (string-index piece #\=)))
(if equals (if equals
(cons (uri-decode (substring piece 0 equals) #:charset charset) (cons (uri-decode (substring piece 0 equals) #:encoding charset)
(uri-decode (substring piece (1+ equals)) #:charset charset)) (uri-decode (substring piece (1+ equals)) #:encoding charset))
(cons (uri-decode piece #:charset charset) "")))) (cons (uri-decode piece #:encoding charset) ""))))
(string-split str #\&))) (string-split str #\&)))
(define (request-relative-path r) (define (request-relative-path r)
@ -88,7 +88,7 @@
(charset (or (assoc-ref (cdr content-type) "charset") (charset (or (assoc-ref (cdr content-type) "charset")
"utf-8"))) "utf-8")))
(cond (cond
((equal? (car content-type) "application/x-www-form-urlencoded") ((equal? (car content-type) 'application/x-www-form-urlencoded)
(parse-www-form-urlencoded body charset)) (parse-www-form-urlencoded body charset))
(else (else
(error "bad content-type" content-type))))))) (error "bad content-type" content-type)))))))
@ -97,13 +97,11 @@
(define (request-authenticated? request) (define (request-authenticated? request)
(let ((auth (request-authorization request))) (let ((auth (request-authorization request)))
(and auth (and auth
(match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64) (match-bind "^([^:]*):(.*)$"
(match-bind "^([^:]*):(.*)$" (utf8->string (base64-decode (cdr auth)))
(utf8->string (base64-decode b64)) (_ user pass)
(_ user pass) (and (equal? user *admin-user*)
(and (equal? user *admin-user*) (equal? pass *admin-pass*))
(equal? pass *admin-pass*))
#f)
#f)))) #f))))
(define-syntax path-proc-case (define-syntax path-proc-case