Changeset 12655 in project


Ignore:
Timestamp:
11/29/08 19:56:15 (11 years ago)
Author:
sjamaan
Message:

Restore access-file handling, add back tests for this case and others

Location:
release/4/spiffy/trunk
Files:
4 edited

Legend:

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

    r12587 r12655  
    4545   server-software root-path server-port index-files mime-type-map
    4646   default-mime-type file-extension-handlers default-host vhost-map
    47    access-log error-log debug-log spiffy-user spiffy-group
     47   access-log error-log debug-log spiffy-user spiffy-group access-file
    4848   handle-directory handle-not-found handle-exception handle-access-logging
    4949   restart-request htmlize)
     
    9797(define spiffy-user (make-parameter #f))
    9898(define spiffy-group (make-parameter #f))
     99(define access-file (make-parameter #f))
    99100
    100101;;; Custom handlers
     
    275276     (lambda () (send-status 301 "Moved permanently")))))
    276277
     278(define (apply-access-file path continue)
     279  (let ((file (make-pathname path (access-file))))
     280    (if (and (access-file) (file-exists? file))
     281        ((eval (call-with-input-file file read)) continue)
     282        (continue))))
     283
    277284(define (process-entry current-path remaining-path)
    278285  (let ((path (make-pathname (root-path) current-path)))
     
    280287     ;; TODO Check if there's a registered URI-handler first
    281288     ((directory? path)
    282       (match remaining-path
    283        (()    (redirect-directory-root (make-pathname "/" current-path)))
    284        (("/") (process-directory current-path))
    285        (else  (process-entry (make-pathname current-path (car remaining-path))
    286                              (cdr remaining-path)))))
     289      (apply-access-file path
     290       (lambda ()
     291         (match remaining-path
     292                (()    (redirect-directory-root (make-pathname "/" current-path)))
     293                (("/") (process-directory current-path))
     294                (else  (process-entry (make-pathname current-path (car remaining-path))
     295                                      (cdr remaining-path)))))))
    287296     ((file-exists? path)
    288297      (parameterize ((current-pathinfo remaining-path)
  • release/4/spiffy/trunk/tests/run.scm

    r12583 r12655  
    77(load "testlib")
    88
     9(define noway "No way, Jose!")
     10
     11(define counter 0)
     12
    913(parameterize
    1014    ((default-mime-type 'application/unknown)
    11      (handle-directory (send-string/code 403 "Forbidden" "forbidden"))
     15     (handle-directory (lambda (p) (send-string/code 403 "Forbidden" "forbidden")))
     16     (access-file "spiffy-access")
    1217     (vhost-map
    1318      `(("foohost" . , (lambda (continue)
     
    1621                                     (continue)))
    1722        ("redirect-host" . ,(lambda (continue)
    18                               (with-headers `((location "/move-along"))
    19                                 (send-status 301 "Moved permanently"))))
     23                              (with-headers `((location ,(uri-reference "/move-along")))
     24                                (lambda ()
     25                                  (send-status 303 "Moved")))))
    2026        ("error-host" . ,(lambda (continue)
    2127                           (error "This should give a 500 error")))
     
    6874(test "break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "../hello.txt" "subdir-host"))
    6975(test-end "path normalization")
     76
     77(test-begin "access files")
     78(set! counter 0)
     79(test "Two slashes" `(200 ,index-subdir) (fetch-file "subdir//" "testhost"))
     80(test "After two slashes, counter is 1" 1 counter)
     81(test "Dir request" `(200 ,noway) (fetch-file "secrets" "testhost")) ;; Access file applies on dir and all below
     82(test "File request in dir" `(200 ,noway) (fetch-file "secrets/password.txt" "testhost"))
     83(test "Subdir request" `(200 ,noway) (fetch-file "secrets/bank" "testhost"))
     84(test "File request in subdir" `(200 ,noway) (fetch-file "secrets/bank/pin-code.txt" "testhost"))
     85(test-end "access files")
     86
     87(test-begin "miscellaneous")
     88(test "redirect" 303 (car (fetch-file "blah" "redirect-host")))
     89(test "redirect location" (uri-reference "/move-along") (header-value 'location (get-headers "blah" "redirect-host")))
     90(test "internal error" `(500 ,EXN) (fetch-file "cause-error" "error-host"))
     91(set! counter 0)
     92(test "load-once" `(200 "") (fetch-file "load-once-resource" "localhost"))
     93(test "After load-once, counter is 1" 1 counter)
     94(test-end "miscellaneous")
  • release/4/spiffy/trunk/tests/testlib.scm

    r12583 r12655  
    2929
    3030(define (send-string/code code reason string)
    31   (lambda (p)
    32     (current-response
    33      (update-response (current-response)
    34                       code: code reason: reason))
    35     (write-logged-response)
    36     (fprintf (response-port (current-response)) string)))
     31  (current-response
     32   (update-response (current-response)
     33                    code: code reason: reason))
     34  (write-logged-response)
     35  (display string (response-port (current-response))))
     36
     37(define EXN "Some exception was thrown")
    3738
    3839(define (start-spiffy)
     
    4344           (parameterize ((root-path "./testweb")
    4445                          (error-log (getenv "SPIFFY_ERROR_LOG"))
    45                           (handle-not-found (send-string/code 404 "Not found" NOT-FOUND)))
     46                          (handle-not-found
     47                           (lambda (p)
     48                             (send-string/code 404 "Not found" NOT-FOUND)))
     49                          (handle-exception
     50                           (lambda (exn chain)
     51                             (log-to (error-log) (build-error-message exn chain #t))
     52                             (send-string/code 500 "Internal server error" EXN))))
    4653             (start-server)))))
    4754  (thread-start! spiffy-thread)
  • release/4/spiffy/trunk/tests/testweb/secrets/spiffy-access

    r5735 r12655  
    11(lambda (continue)
    2   (write-fragment-response noway))
     2  (with-headers `((content-length ,(string-length noway)))
     3    (lambda ()
     4     (write-logged-response)
     5     (display noway (response-port (current-response))))))
Note: See TracChangeset for help on using the changeset viewer.