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

fix default chibi.net.http-server file server for paths other than .

Browse source
This commit is contained in:
Alex Shinn 2019-01-03 07:39:08 +08:00
parent 336a69a416
commit c9b4786648
1 changed files with 19 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1,11 +1,11 @@
;; http-server.scm -- combinator-based http server ;; http-server.scm -- combinator-based http server
;; Copyright (c) 2013-2015 Alex Shinn. All rights reserved. ;; Copyright (c) 2013-2019 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;> Runs an http server listening at the given address, with the given ;;> Runs an http server listening at the given address, with the given
;;> servlet. ;;> servlet.
;;> ;;>
;;> An servlet is a procedure which takes four arguments: a ;;> A servlet is a procedure which takes four arguments: a
;;> \scheme{(chibi config)} config object, an \scheme{Http-Request} record, ;;> \scheme{(chibi config)} config object, an \scheme{Http-Request} record,
;;> which contains the I/O ports and parsed request and headers; ;;> which contains the I/O ports and parsed request and headers;
;;> a \scheme{next} procedure to call the next available servlet if any, ;;> a \scheme{next} procedure to call the next available servlet if any,
@ -82,17 +82,20 @@
(next cfg request)))) (next cfg request))))
;; Generate a simple page listing the linked files in a directory. ;; Generate a simple page listing the linked files in a directory.
(define (send-directory path out) (define (send-directory path out . o)
(display "<html><body bgcolor=white><pre>\n" out) (let ((base-dir (if (and (pair? o) (car o))
(for-each (path-relative-to path (car o))
(lambda (file) path)))
(display "<a href=\"/" out) (display "<html><body bgcolor=white><pre>\n" out)
(display (path-normalize (make-path path file)) out) (for-each
(display "\">" out) (lambda (file)
(display file out) (display "<a href=\"/" out)
(display "</a>\n" out)) (display (path-normalize (make-path base-dir file)) out)
(sort (directory-files path))) (display "\">" out)
(display "</pre></body></html>\n" out)) (display file out)
(display "</a>\n" out))
(sort (directory-files path)))
(display "</pre></body></html>\n" out)))
;; TODO: If the index-rx is a short list of fixed strings, check ;; TODO: If the index-rx is a short list of fixed strings, check
;; individually to avoid the full directory lookup. ;; individually to avoid the full directory lookup.
@ -101,7 +104,7 @@
(any (lambda (f) (and (regexp-matches? index-rx f) (make-path dir f))) (any (lambda (f) (and (regexp-matches? index-rx f) (make-path dir f)))
(directory-files dir)))) (directory-files dir))))
(define (http-send-directory request path index-rx restart) (define (http-send-directory request path index-rx restart . o)
(cond (cond
((find-index-file path index-rx) ((find-index-file path index-rx)
=> (lambda (index-file) => (lambda (index-file)
@ -113,7 +116,7 @@
(request-with-uri request (uri-with-path uri path2)))))) (request-with-uri request (uri-with-path uri path2))))))
(else (else
(servlet-respond request 200 "OK") (servlet-respond request 200 "OK")
(send-directory path (request-out request))))) (apply send-directory path (request-out request) o))))
(define (http-send-file request path) (define (http-send-file request path)
(cond (cond
@ -130,7 +133,7 @@
(lambda (cfg request next restart) (lambda (cfg request next restart)
(let ((path (make-path dir (request-path request)))) (let ((path (make-path dir (request-path request))))
(if (file-directory? path) (if (file-directory? path)
(http-send-directory request path index-rx restart) (http-send-directory request path index-rx restart dir)
(http-send-file request path))))))) (http-send-file request path)))))))
(define (http-procedure-servlet path proc) (define (http-procedure-servlet path proc)