Changeset 11985 in project for release/4/spiffy/trunk/spiffy.scm


Ignore:
Timestamp:
09/23/08 22:58:18 (13 years ago)
Author:
sjamaan
Message:

Rearrange code a bit to make it more logical and easy to follow

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/spiffy/trunk/spiffy.scm

    r11984 r11985  
    131131              (file-close fd)))))
    132132
     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
    133178;; Determine the vhost to use. This tries to use the Host: header first
    134179;; and it it's not there, falls back to try to determine the vhost
     
    145190            #f
    146191            (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-response
    153                   (update-response
    154                    (current-response)
    155                    headers: (headers new-headers
    156                                      (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-page
    165         (process-entry (make-pathname path index-page) '())
    166         ((handle-directory) path))))
    167 
    168 ;; If an URL is missing a trailing slash, instead of directly serving
    169 ;; its index-file, redirect to the URL _with_ trailing slash.  This
    170 ;; prevents problems with relative references since the directory
    171 ;; 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     (cond
    182      ;; Check if there's a registered URI-handler first
    183      ((directory? path)
    184       (match remaining-path
    185        (()    (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))))))
    192192
    193193(define (handle-incoming-request in out)
Note: See TracChangeset for help on using the changeset viewer.