Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-03 19:26:36 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

Updating chibi.net.http with mime changes.

Browse source
This commit is contained in:
Alex Shinn 2013-07-23 07:35:34 +09:00
parent 6dea74036a
commit e0e23fc0fd
1 changed files with 10 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
lib/chibi/net/http.scm
View file

@ -1,5 +1,5 @@
;; http.scm -- http client ;; http.scm -- http client
;; Copyright (c) 2009 Alex Shinn. All rights reserved. ;; Copyright (c) 2009-2013 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -82,7 +82,7 @@
(display " HTTP/1.0\r\n" out) (display " HTTP/1.0\r\n" out)
(display "Host: " out) (display host out) (display "\r\n" out) (display "Host: " out) (display host out) (display "\r\n" out)
(cond (cond
((not (mime-ref in-headers "user-agent")) ((not (assq-ref in-headers 'user-agent))
(display "User-Agent: " out) (display "User-Agent: " out)
(display http-user-agent out) (display http-user-agent out)
(display "\r\n" out))) (display "\r\n" out)))
@ -98,7 +98,7 @@
(status (quotient (cadr resp) 100))) (status (quotient (cadr resp) 100)))
(case status (case status
((2) ((2)
(let ((enc (mime-ref headers "transfer-encoding"))) (let ((enc (assq-ref headers 'transfer-encoding)))
(cond (cond
((equal? enc "chunked") ((equal? enc "chunked")
(http-wrap-chunked-input-port in)) (http-wrap-chunked-input-port in))
@ -107,7 +107,7 @@
((3) ((3)
(close-input-port in) (close-input-port in)
(close-output-port out) (close-output-port out)
(let ((url2 (mime-ref headers "location"))) (let ((url2 (assq-ref headers 'location)))
(if url2 (if url2
(http-get/raw url2 in-headers (- limit 1)) (http-get/raw url2 in-headers (- limit 1))
(error "redirect with no location header")))) (error "redirect with no location header"))))
@ -147,13 +147,14 @@
;; query or form parameter. ;; query or form parameter.
(define (http-parse-form uri headers . o) (define (http-parse-form uri headers . o)
(let* ((in (if (pair? o) (car o) (current-input-port))) (let* ((in (if (pair? o) (car o) (current-input-port)))
(type (mime-ref headers (type (assq-ref headers
"content-type" 'content-type
"application/x-www-form-urlencoded")) "application/x-www-form-urlencoded"))
(query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '())) (query0 (or (uri-query (if (string? uri) (string->uri uri) uri)) '()))
(query (if (string? query0) (uri-query->alist query0) query0))) (query (if (string? query0) (uri-query->alist query0) query0)))
(cond (cond
((string-ci=? "multipart/" type) ((and (>= (string-length type) 10)
(string-ci=? "multipart/" (substring type 0 10)))
(let ((mime (mime-message->sxml in headers))) (let ((mime (mime-message->sxml in headers)))
(append (append
(let lp ((ls (cddr mime)) (let lp ((ls (cddr mime))
@ -166,9 +167,9 @@
(pair? (cdar ls)) (pair? (cdar ls))
(pair? (car (cdar ls))) (pair? (car (cdar ls)))
(memq (caar (cdar ls)) '(^ @))) (memq (caar (cdar ls)) '(^ @)))
(let* ((disp0 (mime-ref (cdar (cdar ls)) "content-disposition" "")) (let* ((disp0 (assq-ref (cdar (cdar ls)) 'content-disposition ""))
(disp (mime-parse-content-type disp0)) (disp (mime-parse-content-type disp0))
(name (mime-ref disp "name"))) (name (assq-ref disp 'name)))
(if name (if name
(lp (cdr ls) (cons (cons name (cadr (cdar ls))) res)) (lp (cdr ls) (cons (cons name (cadr (cdar ls))) res))
(lp (cdr ls) res)))) (lp (cdr ls) res))))