Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-22 07:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding binary upload utilities, allowing specifying headers in servlet-write.

Browse source
This commit is contained in:
Alex Shinn 2014-04-06 22:03:18 +09:00
parent 0c33f4fa1a
commit 4af92d328f
2 changed files with 33 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
lib/chibi/net/servlet.scm
View file

@ -21,15 +21,36 @@
(define (upload-headers upload)
(cadr (upload-sxml upload)))
(define (upload->string upload)
(define (upload-content upload)
(car (cddr (upload-sxml upload))))
(define (upload->string upload)
(let ((x (upload-content upload)))
(if (bytevector? x) (utf8->string x) x)))
(define (upload->bytevector upload)
(let ((x (upload-content upload)))
(if (string? x) (string->utf8 x) x)))
(define (upload->sexp upload)
(let* ((in (upload-input-port upload))
(res (read in)))
(close-input-port in)
res))
(define (upload-input-port upload)
(open-input-string (upload->string upload)))
(define (upload-binary-input-port upload)
(open-input-bytevector (upload->bytevector upload)))
(define (upload-save upload path)
(call-with-output-file path
(lambda (out) (display (upload->string upload) out))))
(let ((content (upload-content upload)))
(call-with-output-file path
(lambda (out)
(if (string? content)
(display content out)
(write-bytevector content out))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Requests.
@ -147,21 +168,22 @@
,@headers))))))
(mime-write-headers headers out)
(display "\r\n" out)
(flush-output out)))))
(flush-output-port out)))))
;;> Write the contents of a string to the request. If no status has
;;> been sent, assume a default of 200.
(define (servlet-write request str)
(define (servlet-write request str . o)
(if (not (request-status request))
(servlet-respond request 200 "OK"))
(apply servlet-respond request 200 "OK" o))
(display str (request-out request)))
(define (extract-form-data sxml)
(define (form-data x)
(and (pair? x) (eq? 'mime (car x))
(pair? (cdr x)) (pair? (cadr x)) (eq? '@ (car (cadr x)))
(string? (car (cddr x)))
(or (string? (car (cddr x)))
(bytevector? (car (cddr x))))
(assq 'content-disposition (cdr (cadr x)))))
(let lp ((ls sxml) (res '()) (files '()))
(cond

6
lib/chibi/net/servlet.sld
View file

@ -4,8 +4,9 @@
;; uploads
upload? upload-name upload-filename
upload-headers upload->string upload-input-port upload-save
upload->bytevector upload->sexp upload-binary-input-port
;; requests
request? request-method request-host
request? request-method request-host request-uploads
request-uri request-version request-headers request-body request-params
request-in request-out request-sock request-addr request-param
request-method-set! request-host-set! request-uri-set!
@ -20,7 +21,8 @@
make-status-servlet servlet-handler servlet-run
servlet-bad-request)
(import
(chibi) (srfi 9) (srfi 39) (srfi 69) (srfi 98)
(scheme base) (scheme read) (scheme write) (scheme file)
(srfi 9) (srfi 39) (srfi 69) (srfi 98)
(chibi ast) (chibi io) (chibi uri) (chibi mime) (chibi log) (chibi config)
(chibi filesystem) (chibi net) (chibi net server-util))
(include "servlet.scm"))