Changeset 11985 in project
- Timestamp:
- 09/23/08 22:58:18 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/spiffy/trunk/spiffy.scm
r11984 r11985 131 131 (file-close fd))))) 132 132 133 (define (extension->mime-type ext) 134 (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type))) 135 136 (define (with-headers new-headers thunk) 137 (parameterize ((current-response 138 (update-response 139 (current-response) 140 headers: (headers new-headers 141 (response-headers (current-response)))))) 142 (thunk))) 143 144 (define (process-directory path) 145 (let ((index-page (find (lambda (ip) 146 (file-exists? 147 (make-pathname (list (root-path) path) ip))) 148 (index-files)))) 149 (if index-page 150 (process-entry (make-pathname path index-page) '()) 151 ((handle-directory) path)))) 152 153 ;; If an URL is missing a trailing slash, instead of directly serving 154 ;; its index-file, redirect to the URL _with_ trailing slash. This 155 ;; prevents problems with relative references since the directory 156 ;; would be seen as the file component in the path and get replaced. 157 (define (redirect-directory-root path) 158 (let* ((newloc (make-pathname path "/")) 159 (url (uri-relative-to (uri-reference newloc) 160 (request-uri (current-request))))) 161 (with-headers `((location ,url)) 162 (lambda () (send-status 301 "Moved permanently"))))) 163 164 (define (process-entry current-path remaining-path) 165 (let ((path (make-pathname (root-path) current-path))) 166 (cond 167 ;; Check if there's a registered URI-handler first 168 ((directory? path) 169 (match remaining-path 170 (() (redirect-directory-root current-path)) 171 (("/") (process-directory current-path)) 172 (else (process-entry (make-pathname current-path (car remaining-path)) 173 (cdr remaining-path))))) 174 ((file-exists? path) 175 ((handle-file) path)) 176 (else ((handle-not-found)))))) 177 133 178 ;; Determine the vhost to use. This tries to use the Host: header first 134 179 ;; and it it's not there, falls back to try to determine the vhost … … 145 190 #f 146 191 (or (uri-host (request-uri (current-request))) ""))))) 147 148 (define (extension->mime-type ext)149 (alist-ref (or ext "") (mime-type-map) string-ci=? (default-mime-type)))150 151 (define (with-headers new-headers thunk)152 (parameterize ((current-response153 (update-response154 (current-response)155 headers: (headers new-headers156 (response-headers (current-response))))))157 (thunk)))158 159 (define (process-directory path)160 (let ((index-page (find (lambda (ip)161 (file-exists?162 (make-pathname (list (root-path) path) ip)))163 (index-files))))164 (if index-page165 (process-entry (make-pathname path index-page) '())166 ((handle-directory) path))))167 168 ;; If an URL is missing a trailing slash, instead of directly serving169 ;; its index-file, redirect to the URL _with_ trailing slash. This170 ;; prevents problems with relative references since the directory171 ;; would be seen as the file component in the path and get replaced.172 (define (redirect-directory-root path)173 (let* ((newloc (make-pathname path "/"))174 (url (uri-relative-to (uri-reference newloc)175 (request-uri (current-request)))))176 (with-headers `((location ,url))177 (lambda () (send-status 301 "Moved permanently")))))178 179 (define (process-entry current-path remaining-path)180 (let ((path (make-pathname (root-path) current-path)))181 (cond182 ;; Check if there's a registered URI-handler first183 ((directory? path)184 (match remaining-path185 (() (redirect-directory-root current-path))186 (("/") (process-directory current-path))187 (else (process-entry (make-pathname current-path (car remaining-path))188 (cdr remaining-path)))))189 ((file-exists? path)190 ((handle-file) path))191 (else ((handle-not-found))))))192 192 193 193 (define (handle-incoming-request in out)
Note: See TracChangeset
for help on using the changeset viewer.