mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 17:00:23 +02:00
Code Activity

fix read-{request,response}-body/latin-1

Browse source 
* module/web/request.scm (read-response-body/latin-1):
* module/web/response.scm (read-response-body/latin-1): Avoid the
  craziness of the read-delimited! interface and hand-roll our
  own. Fixes errors if read-delimited returns #f or EOF.
This commit is contained in:
Andy Wingo 2010-12-06 15:30:45 +01:00
parent e7fb779fb0
commit e46f69e25c
2 changed files with 37 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

28
module/web/request.scm
View file

@ -192,15 +192,25 @@
;; Probably not what you want to use "in production". Relies on one byte ;; Probably not what you want to use "in production". Relies on one byte
;; per char because we are in latin-1 encoding. ;; per char because we are in latin-1 encoding.
;; ;;
(define (read-request-body/latin-1 r) (define (read-response-body/latin-1 r)
(let ((nbytes (request-content-length r))) (cond
(and nbytes ((request-content-length r) =>
(let* ((buf (make-string nbytes)) (lambda (nbytes)
(n (read-delimited! "" buf (request-port r)))) (let ((buf (make-string nbytes))
(if (= n nbytes) (port (request-port r)))
buf (let lp ((i 0))
(bad-request "EOF while reading request body: ~a bytes of ~a" (cond
n nbytes)))))) ((< i nbytes)
(let ((c (read-char port)))
(cond
((eof-object? c)
(bad-request "EOF while reading request body: ~a bytes of ~a"
i nbytes))
(else
(string-set! buf i c)
(lp (1+ i))))))
(else buf))))))
(else #f)))
;; Likewise, assumes that body can be written in the latin-1 encoding, ;; Likewise, assumes that body can be written in the latin-1 encoding,
;; and that the latin-1 encoding is what is expected by the server. ;; and that the latin-1 encoding is what is expected by the server.

26
module/web/response.scm
View file

@ -185,14 +185,24 @@
;; per char because we are in latin-1 encoding. ;; per char because we are in latin-1 encoding.
;; ;;
(define (read-response-body/latin-1 r) (define (read-response-body/latin-1 r)
(let ((nbytes (response-content-length r))) (cond
(and nbytes ((response-content-length r) =>
(let* ((buf (make-string nbytes)) (lambda (nbytes)
(n (read-delimited! "" buf (response-port r)))) (let ((buf (make-string nbytes))
(if (= n nbytes) (port (response-port r)))
buf (let lp ((i 0))
(bad-response "EOF while reading response body: ~a bytes of ~a" (cond
n nbytes)))))) ((< i nbytes)
(let ((c (read-char port)))
(cond
((eof-object? c)
(bad-response "EOF while reading response body: ~a bytes of ~a"
i nbytes))
(else
(string-set! buf i c)
(lp (1+ i))))))
(else buf))))))
(else #f)))
;; Likewise, assumes that body can be written in the latin-1 encoding, ;; Likewise, assumes that body can be written in the latin-1 encoding,
;; and that the latin-1 encoding is what is expected by the server. ;; and that the latin-1 encoding is what is expected by the server.