mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

flesh out (web server)'s sanitize-response

Browse source 
* module/web/server.scm (sanitize-response): Flesh out. If we get a
  string, we encode it to a bytevector using the encoding snarfed from
  the response. We should check the request, though...
This commit is contained in:
Andy Wingo 2010-11-13 18:31:34 +01:00
parent 3d95977991
commit d9f00c3db5
1 changed files with 37 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

38
module/web/server.scm
View file

@ -156,9 +156,45 @@
(warn "Error handling request" k args)
(apply values (build-response #:code 500) #f state))))
(define (encode-string str charset)
(case charset
((utf-8) (string->utf8 str))
(else (error "unknown charset" charset))))
;; -> response body
(define (sanitize-response request response body)
(values response body))
(cond
((list? response)
(sanitize-response request (build-response #:headers response) body))
((string? body)
(let* ((type (response-content-type response
'("text/plain")))
(declared-charset (assoc-ref (cdr type) "charset"))
(charset (if declared-charset
(string->symbol
(string-downcase declared-charset))
'utf-8)))
(sanitize-response
request
(if declared-charset
response
(extend-response response 'content-type
`(,@type ("charset" . ,(symbol->string charset)))))
(encode-string body charset))))
((procedure? body)
(sanitize-response request response (call-with-output-string body)))
((bytevector? body)
;; check length; assert type; add other required fields?
(values (let ((len (response-content-length response)))
(if len
(if (= len (bytevector-length body))
response
(error "bad content-length" len (bytevector-length body)))
(extend-response response 'content-length
(bytevector-length body))))
body))
(else
(error "unexpected body type"))))
;; -> (#f | client)
(define (write-client impl server client response body)