Changeset 29916 in project


Ignore:
Timestamp:
10/13/13 20:36:37 (8 years ago)
Author:
sjamaan
Message:

Spiffy: Further improved debugging and graceful handling of disconnections

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

Legend:

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

    r27850 r29916  
    66 (category web)
    77 (license "BSD")
    8  (depends (intarweb 1.0) uri-common uri-generic (sendfile 1.7))
     8 (depends (intarweb "1.2") uri-common uri-generic (sendfile "1.7"))
    99 (test-depends test))
  • release/4/spiffy/trunk/spiffy.scm

    r29835 r29916  
    186186      (apply printf fmt rest)
    187187      (newline))))
     188
     189;; Handy shortcut for logging to the debug log with the current
     190;; thread name prefixed to the log.
     191(define (debug! m . args)
     192  (apply log-to (debug-log)
     193         (conc "~A: " m) (thread-name (current-thread)) args))
    188194
    189195(define build-error-message
     
    441447
    442448(define (restart-request req)
     449  (debug! "Restarting request from ~A (with uri: ~A)"
     450          (remote-address) (request-uri req))
    443451  ((request-restarter) req (request-restarter)))
     452
     453(define (determine-remote-address-with-trusted-proxies req)
     454  ;; If the remote end is untrusted, that's the remote address.
     455  ;; If it's trusted, see who it forwarded the request for and loop.
     456  ;; Take care to stop on a trusted host if there's no additional
     457  ;; forwarded-for entry (someone may initiate a request on a trusted host).
     458  (let lp ((address-chain (cons (remote-address)
     459                                (reverse
     460                                 (header-values 'x-forwarded-for
     461                                                (request-headers req))))))
     462    (if (and (member (car address-chain) (trusted-proxies))
     463             (not (null? (cdr address-chain))))
     464        (lp (cdr address-chain))
     465        (car address-chain))))
    444466
    445467(define (handle-incoming-request in out)
     
    448470      (close-input-port in)
    449471      (close-output-port out)
    450       (log-to (debug-log) "~A: ~A" (thread-name (current-thread))
    451               (build-error-message exn chain #t))
     472      (debug! "~A" (build-error-message exn chain #t))
    452473      #f)                          ; Do not keep going
    453474    (receive (req cont)
    454       (call/cc (lambda (c) (values (read-request in) c)))
    455       ;; If the remote end is untrusted, that's the remote address.
    456       ;; If it's trusted, see who it forwarded the request for and loop.
    457       ;; Take care to stop on a trusted host if there's no additional
    458       ;; forwarded-for entry (someone may initiate a request on a trusted host).
    459       (let lp ((address-chain (cons (remote-address)
    460                                     (reverse
    461                                      (header-values 'x-forwarded-for
    462                                                     (request-headers req))))))
    463         (if (and (member (car address-chain) (trusted-proxies))
    464                  (not (null? (cdr address-chain))))
    465             (lp (cdr address-chain))
    466             (remote-address (car address-chain))))
    467       (parameterize ((current-request
    468                       (update-request req uri: (normalize-uri req)))
    469                      (current-response
    470                       (make-response port: out
    471                                      headers: (intarweb:headers
    472                                                `((content-type text/html)
    473                                                  (server ,(server-software))))))
    474                      (request-restarter cont))
    475         (handle-exceptions exn
    476           (begin
    477             ((handle-exception) exn
    478              (with-output-to-string print-call-chain))
    479             #f)                         ; Do not keep going
    480           (let ((host (uri-host (request-uri (current-request)))))
    481             (if (and host (uri-path-absolute? (request-uri (current-request))))
    482                 (let ((handler
    483                        (alist-ref host (vhost-map)
    484                                   (lambda (h _)
    485                                     (irregex-match (irregex h 'i) host)))))
    486                   (if handler
    487                       (handler (lambda ()
    488                                  (process-entry
    489                                   "" "" (cdr (uri-path (request-uri
    490                                                         (current-request)))))))
    491                       ;; Is this ok?
    492                       ((handle-not-found) (uri-path (request-uri (current-request))))))
    493                 ;; No host or non-absolute URI in the request is an error.
    494                 (send-status 'bad-request
    495                              "<p>Your client sent a request that the server did not understand</p>"))
    496             (unless (##sys#slot out 8) ;; port-closed?
    497              (flush-output out))
    498             (handle-another-request?))))))) ; Keep going?
     475        (call/cc (lambda (c) (values (read-request in) c)))
     476      (and req ; No request? Then the connection was closed. Don't keep going.
     477           (parameterize ((remote-address
     478                           (determine-remote-address-with-trusted-proxies req))
     479                          (current-request
     480                           (update-request req uri: (normalize-uri req)))
     481                          (current-response
     482                           (make-response
     483                            port: out
     484                            headers: (intarweb:headers
     485                                      `((content-type text/html)
     486                                        (server ,(server-software))))))
     487                          (request-restarter cont))
     488             (debug! "Handling request from ~A" (remote-address))
     489             (handle-exceptions exn
     490                 (begin
     491                   ((handle-exception) exn
     492                    (with-output-to-string print-call-chain))
     493                   #f)                  ; Do not keep going
     494               (let ((host (uri-host (request-uri (current-request)))))
     495                 (if (and host (uri-path-absolute? (request-uri (current-request))))
     496                     (let ((handler
     497                            (alist-ref host (vhost-map)
     498                                       (lambda (h _)
     499                                         (irregex-match (irregex h 'i) host)))))
     500                       (if handler
     501                           (handler (lambda ()
     502                                      (process-entry
     503                                       "" ""
     504                                       (cdr (uri-path (request-uri
     505                                                       (current-request)))))))
     506                           ;; Is this ok?
     507                           ((handle-not-found)
     508                            (uri-path (request-uri (current-request))))))
     509                     ;; No host or non-absolute URI in the request is an error.
     510                     (send-status 'bad-request
     511                                  (conc "<p>Your client sent a request that "
     512                                        "the server did not understand</p>")))
     513                 (unless (##sys#slot out 8) ;; port-closed?
     514                   (flush-output out))
     515                 (handle-another-request?)))))))) ; Keep going?
    499516
    500517(define (htmlize str)
     
    560577  (let ((thread-count (make-mutex/value 'thread-count 0))
    561578        (thread-stopped! (make-condition-variable 'thread-stopped!))
    562         (exn-message (condition-property-accessor 'exn 'message "(no message)"))
    563         (debug! (lambda (m . args)
    564                   (apply log-to (debug-log) (conc "~A: " m)
    565                          (thread-name (current-thread)) args))))
     579        (exn-message (condition-property-accessor 'exn 'message "(no message)")))
    566580    (let accept-next-connection ()
    567581      ;; Wait until we have a free connection slot
     
    573587          (let*-values (((in out)       (accept listener))
    574588                        ((local remote) (addresses in)))
    575             (debug! "Incoming request from ~A" remote)
    576589            (mutex-update! thread-count add1)
    577590            (thread-start!
    578591             (lambda ()
    579                (debug! "Handling request from ~A" remote)
     592               (debug! "Incoming request from ~A" remote)
    580593               ;; thread-count _must_ be updated, so trap all exns
    581594               (handle-exceptions
Note: See TracChangeset for help on using the changeset viewer.