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


Ignore:
Timestamp:
11/23/08 23:51:01 (12 years ago)
Author:
sjamaan
Message:

Port tests from spiffy 3 to spiffy 4, implement a few bugfixes too

File:
1 edited

Legend:

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

    r12538 r12583  
    3535; ticket tracking system (assign tickets to user 'sjamaan'):
    3636; http://trac.callcc.org
     37
     38(provide 'spiffy)
    3739
    3840(module spiffy
     
    268270;; would be seen as the file component in the path and get replaced.
    269271(define (redirect-directory-root path)
    270   (let* ((newloc (make-pathname path "/"))
    271          (url (uri-relative-to (uri-reference newloc)
    272                                (request-uri (current-request)))))
    273     (with-headers `((location ,url))
    274       (lambda () (send-status 301 "Moved permanently")))))
     272  (let ((new-path (uri-path (uri-reference (string-append path "/")))))
     273   (with-headers `((location ,(update-uri (request-uri (current-request))
     274                                          path: new-path)))
     275     (lambda () (send-status 301 "Moved permanently")))))
    275276
    276277(define (process-entry current-path remaining-path)
     
    309310
    310311(define (normalize-current-request-uri)
    311   (receive (host port) (determine-vhost/port)
    312     (if host
    313         (update-request (current-request)
    314                         uri: (uri-relative-to
    315                               (request-uri (current-request))
    316                               ;; XXX
    317                               (absolute-uri (conc "http://" host ":" port))))
    318         (current-request))))
     312  (receive (host port)
     313    (determine-vhost/port)
     314    (let* ((uri (request-uri (current-request)))
     315           (host (or host (uri-host uri)))
     316           (port (or port (uri-port uri))))
     317     (update-request (current-request)
     318                     uri: (uri-normalize-path-segments
     319                           (update-uri uri host: host port: port))))))
    319320
    320321(define request-restarter (make-parameter #f)) ; Internal parameter
     
    326327  (receive (local remote)
    327328    (tcp-addresses in)
    328     (parameterize ((remote-address remote)
    329                    (local-address local)
    330                    (current-request (read-request in))
    331                    (current-response
    332                     (make-response port: out
    333                                    headers: (headers
    334                                              `((content-type text/html)
    335                                                (server ,(server-software)))))))
    336       (let ((path (uri-path (request-uri (current-request)))))
    337         (receive (req cont)
    338           (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
    339           (parameterize ((current-request req)
    340                          (request-restarter cont))
    341             (handle-exceptions
    342              exn ((handle-exception) exn
    343                   (with-output-to-string print-call-chain))
    344              (if (and (uri-host (request-uri (current-request))) (pair? path))
    345                  (let* ((host (uri-host (request-uri (current-request))))
    346                         (handler (alist-ref host (vhost-map)
    347                                             (lambda (h _)
    348                                               (if (not (regexp? h))
    349                                                   (string-match (regexp h #t) host)
    350                                                   (string-match h host))))))
    351                    (if handler
    352                        (handler (lambda () (process-entry "" path)))
    353                        ;; Is this ok?
    354                        (send-status 404 "Not found" "<p>Host not found</p>")))
    355                  ;; No host in the request? That's an error.
    356                  (send-status 400 "Bad request"
    357                               "<p>Your client sent a request that the server did not understand</p>")))))
    358         ;; For now, just close the ports and allow the thread to exit
    359         (close-output-port out)
    360         (close-input-port in)))))
     329    (handle-exceptions ; XXX FIXME; this should be more fine-grained
     330     exn (fprintf out "Invalid request")
     331     (parameterize ((remote-address remote)
     332                    (local-address local)
     333                    (current-request (read-request in))
     334                    (current-response
     335                     (make-response port: out
     336                                    headers: (headers
     337                                              `((content-type text/html)
     338                                                (server ,(server-software)))))))
     339       (receive (req cont)
     340         (call/cc (lambda (c) (values (normalize-current-request-uri) c)))
     341         (parameterize ((current-request req)
     342                        (request-restarter cont))
     343           (handle-exceptions
     344            exn ((handle-exception) exn
     345                 (with-output-to-string print-call-chain))
     346            (let ((path (uri-path (request-uri (current-request)))))
     347              (if (and (uri-host (request-uri (current-request))) (pair? path))
     348                  (let* ((host (uri-host (request-uri (current-request))))
     349                         (handler (alist-ref host (vhost-map)
     350                                             (lambda (h _)
     351                                               (if (not (regexp? h))
     352                                                   (string-match (regexp h #t) host)
     353                                                   (string-match h host))))))
     354                    (if handler
     355                        (handler (lambda () (process-entry "" path)))
     356                        ;; Is this ok?
     357                        ((handle-not-found) path)))
     358                  ;; No host in the request? That's an error.
     359                  (send-status 400 "Bad request"
     360                               "<p>Your client sent a request that the server did not understand</p>"))))))
     361       ;; For now, just close the ports and allow the thread to exit
     362       (close-output-port out)
     363       (close-input-port in)))))
    361364
    362365(define (htmlize str)
    363366  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
    364                            ("\"" . "&quot;") ("&" . "&amp;"))))
     367                           ("\"" . "&quot;") ("'" . "&apos;") ("&" . "&amp;"))))
    365368
    366369;; Do we want this here?
Note: See TracChangeset for help on using the changeset viewer.