Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-15 00:47:34 +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

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

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

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

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