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

adding content-type output for http server files

Browse source
This commit is contained in:
Alex Shinn 2020-07-17 14:42:28 +09:00
parent 983829cab1
commit 7366a13413
4 changed files with 29 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
lib/chibi/mime-test.sld
View file

@ -144,5 +144,10 @@ Content-Transfer-Encoding: binary
--BbC04y--
--AaB03x--
"))))
(test "text/html; charset=utf-8"
(mime-type-from-extension "html"))
(test "text/plain; charset=utf-8"
(mime-type-from-extension "scm"))
(test #f
(mime-type-from-extension "foo"))
(test-end))))

14
lib/chibi/mime.scm
View file

@ -21,6 +21,20 @@
(cond ((and (pair? ls) (pair? (car ls)) (assq key ls)) => cdr)
(else (and (pair? o) (car o)))))
;; most of these are plain text for easier viewing in the browser
(define (mime-type-from-extension ext)
(assq-ref
'((htm . "text/html; charset=utf-8")
(html . "text/html; charset=utf-8")
(scm . "text/plain; charset=utf-8")
(sld . "text/plain; charset=utf-8")
(c . "text/plain; charset=utf-8")
(h . "text/plain; charset=utf-8")
(txt . "text/plain; charset=utf-8")
(org . "text/plain; charset=utf-8")
(md . "text/plain; charset=utf-8"))
(and (string? ext) (string->symbol ext))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; simple matching instead of regexps

3
lib/chibi/mime.sld
View file

@ -2,7 +2,8 @@
(define-library (chibi mime)
(export assq-ref mime-header-fold mime-headers->list
mime-parse-content-type mime-decode-header
mime-message-fold mime-message->sxml mime-write-headers)
mime-message-fold mime-message->sxml mime-write-headers
mime-type-from-extension)
(import (scheme base) (scheme char) (scheme write)
(chibi base64) (chibi quoted-printable)
(chibi string))

9
lib/chibi/net/http-server.scm
View file

@ -129,8 +129,13 @@
(define (http-send-file request path)
(cond
((file-exists? path)
(servlet-respond request 200 "OK")
(send-file path (request-out request)))
(let ((headers
(cond
((mime-type-from-extension (path-extension path))
=> (lambda (type) `((Content-Type . ,type))))
(else '()))))
(servlet-respond request 200 "OK" headers)
(send-file path (request-out request))))
(else
(servlet-respond request 404 "Not Found"))))