Changeset 12150 in project


Ignore:
Timestamp:
10/13/08 21:19:26 (12 years ago)
Author:
sjamaan
Message:

load-verbose should be #f in spiffy

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

Legend:

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

    r12136 r12150  
    4141   server-software root-path server-port index-files mime-type-map
    4242   default-mime-type file-extension-handlers default-host vhost-map
    43    handle-directory handle-not-found
     43   handle-directory handle-not-found handle-exception
    4444   restart-request htmlize)
    4545
     
    101101   (lambda (path)
    102102     (send-status 404 "Not found"
    103                   "The resource you requested could not be found"))))
     103                  "<p>The resource you requested could not be found</p>"))))
     104(define handle-exception
     105  (make-parameter
     106   (lambda (exn chain)
     107     (send-status 500 "Internal server error" (build-error-message exn chain)))))
     108
     109(define build-error-message
     110  (let* ((cpa condition-property-accessor)
     111         (exn-message (cpa 'exn 'message "(no message)"))
     112         (exn-location (cpa 'exn 'location "(unknown location)"))
     113         (exn-arguments (cpa 'exn 'arguments '()))
     114         (exn? (condition-predicate 'exn)))
     115    (lambda (exn chain)
     116      (with-output-to-string
     117        (lambda ()
     118          (if (exn? exn)
     119              (begin
     120                (display "<h2>Error:")
     121                (and-let* ((loc (exn-location exn)))
     122                  (printf " (<em>~A</em>)" (htmlize (->string loc))))
     123                (printf "</h2>\n<h3>~A</h3>\n" (htmlize (exn-message exn)))
     124                (unless (null? (exn-arguments exn))
     125                        (printf "<ul>")
     126                        (for-each
     127                         (lambda (a)
     128                           (##sys#with-print-length-limit 120 (lambda () (printf "<li>~S</li>" (htmlize (->string a))))))
     129                         (exn-arguments exn))
     130                        (printf "</ul>"))
     131                (printf "<pre>~a</pre>" (htmlize chain)))
     132              (begin
     133                (##sys#with-print-length-limit
     134                 120
     135                 (lambda ()
     136                   (printf "<h2>Uncaught exception:</h2>\n~S" exn))))))))))
    104137
    105138;;; Internal parameters
     
    128161        (print "  <body>")
    129162        (printf "    <h1>~A - ~A</h1>\n" code reason)
    130         (if text (printf "    <p>~A</p>" text))
     163        (if text (display text))
    131164        (print "  </body>")
    132165        (print "</html>")))))
     
    137170      (lambda ()
    138171        (write-response (current-response))
    139         (let ([fd (file-open path (+ open/binary open/rdonly))])
     172        (let ((fd (file-open path (+ open/binary open/rdonly))))
    140173          (handle-exceptions exn (begin
    141174                                   (file-close fd)
     
    184217     ((file-exists? path)
    185218      (parameterize ((current-pathinfo remaining-path)
    186                      (current-file path))
    187         ((handle-file) (make-pathname "/" current-path))))
     219                     (current-file (make-pathname "/" current-path)))
     220        ((handle-file) (current-file)))) ;; hmm, not too useful
    188221     (else ((handle-not-found) (list "/" current-path))))))
    189222
     
    230263        (parameterize ((current-request req)
    231264                       (request-restarter cont))
    232           (if (and (uri-host (request-uri (current-request))) (pair? path))
    233               (let* ((host (uri-host (request-uri (current-request))))
    234                      (handler (alist-ref host
    235                                         (vhost-map)
    236                                         (lambda (h _)
    237                                           (if (not (regexp? h))
    238                                               (string-match (regexp h #t) host)
    239                                               (string-match h host))))))
    240                 (if handler
    241                     (handler (lambda () (process-entry "" path)))
    242                     ;; Is this ok?
    243                     (send-status 404 "Not found" "Host not found")))
    244               ;; No host in the request? That's an error.
    245               (send-status 400 "Bad request"
    246                            "Your client sent a request that the server did not understand"))))
     265          (handle-exceptions exn ((handle-exception) exn
     266                                  (with-output-to-string print-call-chain))
     267            (if (and (uri-host (request-uri (current-request))) (pair? path))
     268                (let* ((host (uri-host (request-uri (current-request))))
     269                       (handler (alist-ref host
     270                                           (vhost-map)
     271                                           (lambda (h _)
     272                                             (if (not (regexp? h))
     273                                                 (string-match (regexp h #t) host)
     274                                                 (string-match h host))))))
     275                  (if handler
     276                      (handler (lambda () (process-entry "" path)))
     277                      ;; Is this ok?
     278                      (send-status 404 "Not found" "<p>Host not found</p>")))
     279                ;; No host in the request? That's an error.
     280                (send-status 400 "Bad request"
     281                             "<p>Your client sent a request that the server did not understand</p>")))))
    247282      ;; For now, just close the ports and allow the thread to exit
    248283      (close-output-port out)
     
    250285
    251286(define (htmlize str)
    252   (string-translate* str '(("<" . "&lt;")
    253                            (">" . "&gt;")
    254                            ("\"" . "&quot;")
    255                            ("&" . "&amp;"))))
     287  (string-translate* str '(("<" . "&lt;")    (">" . "&gt;")
     288                           ("\"" . "&quot;") ("&" . "&amp;"))))
    256289
    257290(define (start-server #!key (port (server-port)))
    258   (letrec ((listener (tcp-listen port))
    259            (accept-loop (lambda ()
    260                           (receive (in out)
    261                             (tcp-accept listener)
    262                             (thread-start!
    263                              (make-thread (lambda ()
    264                                             (handle-incoming-request in out))))
    265                             (accept-loop)))))
    266     (accept-loop)))
     291  (parameterize ((load-verbose #f))
     292   (letrec ((listener (tcp-listen port))
     293            (accept-loop (lambda ()
     294                           (receive (in out)
     295                             (tcp-accept listener)
     296                             (thread-start!
     297                              (make-thread (lambda ()
     298                                             (handle-incoming-request in out))))
     299                             (accept-loop)))))
     300     (accept-loop))))
    267301
    268302)
  • release/4/spiffy/trunk/ssp-handler.scm

    r12135 r12150  
    119119  (call/cc
    120120   (lambda (return)
    121      (parameterize (#;(load-verbose #f)
     121     (parameterize ((load-verbose #f)
    122122                    (exit-handler (lambda _ (return #f))))
    123123       (load filename (cut eval <> (ssp-eval-environment)))))))
Note: See TracChangeset for help on using the changeset viewer.