diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 25c7fac..a2b3641 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -121,6 +121,7 @@ thread-fluids ;FORK-THREAD sxml-to-html ;SXML->HTML scsh ;regexp et al. +; httpd-file-directory-handlers ;send-file-response scheme ) (files servlet-handler)) diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 2c9e496..374a6f0 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -107,39 +107,52 @@ (format #f "Bad path: ~s" path))))) (define (launch-new-instance path-string servlet-path req) - (if (file-not-exists? (absolute-file-name path-string servlet-path)) - (make-http-error-response http-status/not-found req path-string) - (begin - (obtain-lock *instance-table-lock*) - ;; no access to instance table until new instance-id is saved - (let ((instance-id (generate-new-table-id *instance-table*)) - (memo (make-memo))) - (table-set! *instance-table* instance-id - (make-instance path-string ; used to make - ; redirections to origin - memo - (make-integer-table) ; continuation table - (make-lock) ; continuation table lock - (make-thread-safe-counter))) ; continuation counter - (release-lock *instance-table-lock*) - (register-session! instance-id 'no-return) - (let ((servlet (with-fatal-error-handler* - (lambda (condition decline) - (delete-instance! instance-id) - (decline)) - (lambda () - (get-servlet-rt-structure path-string servlet-path))))) - (fork-thread (instance-surveillance instance-id - (+ (time) - (options-instance-lifetime)) - memo)) - (reset - (begin - (with-cwd - servlet-path - (with-names-from-rt-structure - servlet servlet-interface - (main req)))))))))) + (cond + ((file-not-exists? (absolute-file-name path-string servlet-path)) + (make-http-error-response http-status/not-found req path-string)) + ((string=? (file-name-extension path-string) ".scm") + (obtain-lock *instance-table-lock*) + ;; no access to instance table until new instance-id is saved + (let ((instance-id (generate-new-table-id *instance-table*)) + (memo (make-memo))) + (table-set! *instance-table* instance-id + (make-instance path-string ; used to make + ; redirections to origin + memo + (make-integer-table) ; continuation table + (make-lock) ; continuation table lock + (make-thread-safe-counter))) ; continuation counter + (release-lock *instance-table-lock*) + (register-session! instance-id 'no-return) + (let ((servlet + (with-fatal-error-handler + (lambda (condition decline) + (delete-instance! instance-id) + (decline)) + (get-servlet-rt-structure path-string servlet-path)))) + (fork-thread (instance-surveillance instance-id + (+ (time) + (options-instance-lifetime)) + memo)) + (reset + (begin + (with-cwd + servlet-path + (with-names-from-rt-structure + servlet servlet-interface + (main req)))))))) + (else ; We'll serve every non-scm file. + ;; We need access to SEND-FILE-RESPONSE of + ;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we + ;; don't have it, so we disable this feature here. +; (let ((full-file-name (absolute-file-name path-string servlet-path))) +; (send-file-response full-file-name +; (file-info full-file-name) +; req)) + (make-http-error-response http-status/forbidden req + "Can't serve other than Scheme files." + path-string)) + )) (define (instance-surveillance instance-id time-to-die memo) (lambda ()