Changeset 33944 in project


Ignore:
Timestamp:
04/08/17 13:54:58 (4 months ago)
Author:
sjamaan
Message:

intarweb: Improve error reporting when unparsing fails due to bad header data

File:
1 edited

Legend:

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

    r33918 r33944  
    121121         (data (read-string limit (request-port request))))
    122122    (if (and (not (eof-object? data)) max-length (= max-length (string-length data)))
    123         (signal-http-condition "Max allowed URLencoded request size exceeded"
    124                                (list request max-length)
    125                                'urlencoded-request-data-limit-exceeded
    126                                'contents data 'limit limit)
     123        (signal-http-condition
     124         'read-urlencoded-request-data
     125         "Max allowed URLencoded request size exceeded"
     126         (list request max-length)
     127         'urlencoded-request-data-limit-exceeded
     128         'contents data 'limit limit)
    127129        (form-urldecode data))))
    128130
     
    133135             (sprintf "~A[..~A+ more chars (was limited to ~A)..]"
    134136               (substring line 0 128) (- limit 128) limit))))
    135     (signal-http-condition "Max allowed line length exceeded"
    136                            (list port safe-line-prefix)
    137                            'line-limit-exceeded 'contents line 'limit limit)))
     137    (signal-http-condition
     138     'safe-read-line
     139     "Max allowed line length exceeded"
     140     (list port safe-line-prefix)
     141     'line-limit-exceeded 'contents line 'limit limit)))
    138142
    139143(define (safe-read-line p)
     
    485489      (update-header-contents!
    486490       header-name (parse-header header-name contents) headers)))
    487    (signal-http-condition "Bad header line" (list line) 'header-error 'contents line)))
     491   (signal-http-condition
     492    'parse-header-line "Bad header line" (list line)
     493    'header-error 'contents line)))
    488494
    489495;; XXXX: Bottleneck?
     
    526532                             (when (eqv? hc header-limit)
    527533                               (signal-http-condition
     534                                'read-headers
    528535                                "Max allowed header count exceeded"
    529536                                (list port)
     
    555562                 (lp (read-char port) (cons c ln) headers hc (add1 len))))))))
    556563
    557 (define (signal-http-condition msg args type . more-info)
     564(define (signal-http-condition loc msg args type . more-info)
    558565  (signal (make-composite-condition
    559566           (make-property-condition 'http)
    560567           (apply make-property-condition type more-info)
    561            (make-property-condition 'exn 'message msg 'arguments args))))
     568           (make-property-condition
     569            'exn 'location loc 'message msg 'arguments args))))
    562570
    563571(defstruct request
     
    632640         (let loop ((parsers (request-parsers)))
    633641           (if (null? parsers)
    634                (signal-http-condition "Unknown protocol line" (list line)
    635                                       'unknown-protocol-line 'line line)
     642               (signal-http-condition
     643                'read-request "Unknown protocol line" (list line)
     644                'unknown-protocol-line 'line line)
    636645               (or ((car parsers) line inport) (loop (cdr parsers))))))))
    637646
     
    679688              (unparse (cond ((assq name unparsers) => cdr) ; inlined for perf
    680689                             (else default-header-unparser))))
    681          (for-each (lambda (value)
    682                      ;; Verify there's no \r\n or \r or \n in value?
    683                      (display (string-append name-s ": " value "\r\n") out))
    684                    (unparse contents))))
     690         (handle-exceptions exn
     691             (let* ((none "(no error message provided in original exn)")
     692                    (msg ((condition-property-accessor
     693                           'exn 'message none) exn))
     694                    (loc ((condition-property-accessor
     695                           'exn 'location #f) exn))
     696                    (args ((condition-property-accessor
     697                           'exn 'arguments '()) exn)))
     698               (signal-http-condition
     699                'unparse-headers
     700                (sprintf "could not unparse ~S header ~S: ~A~A"
     701                  name-s contents (if loc (sprintf "(~A) " loc) "") msg)
     702                args
     703                'unparse-error
     704                'header-name name
     705                'header-value contents
     706                'unparser unparse
     707                'original-exn exn))
     708           (for-each (lambda (value)
     709                       ;; Verify there's no \r\n or \r or \n in value?
     710                       (display (string-append name-s ": " value "\r\n") out))
     711                     (unparse contents)))))
    685712     (headers-v headers))))
    686713
     
    738765        (let ((major (request-major request))
    739766              (minor (request-minor request)))
    740          (signal-http-condition "Unknown protocol" (list (conc major "." minor))
    741                                 'unknown-protocol 'major major 'minor minor))
     767          (signal-http-condition
     768           'write-request
     769           "Unknown protocol" (list (conc major "." minor))
     770           'unknown-protocol 'major major 'minor minor))
    742771        (or ((car unparsers) request) (loop (cdr unparsers))))))
    743772
     
    788817    (if s
    789818        (car s)
    790         (signal-http-condition "Unknown status code" (list c)
    791                                'unknown-code 'code c))))
     819        (signal-http-condition
     820         'response-status "Unknown status code" (list c)
     821         'unknown-code 'code c))))
    792822
    793823(define (http-status->code&reason status)
    794824  (let ((s (alist-ref status (http-status-codes))))
    795825    (unless s
    796       (signal-http-condition "Unknown response status symbol" (list status)
    797                              'unknown-status 'status status))
     826      (signal-http-condition
     827       'http-status->code&reason
     828       ;; haha, status symbol ;)
     829       "Unknown response status symbol"
     830       (list status) 'unknown-status 'status status))
    798831    (values (car s) (cdr s))))
    799832
     
    905938        (let ((major (response-major response))
    906939              (minor (response-minor response)))
    907           (signal-http-condition "Unknown protocol" (list (conc major "." minor))
    908                                  'unknown-protocol 'major major 'minor minor))
     940          (signal-http-condition
     941           'write-response
     942           "Unknown protocol" (list (conc major "." minor))
     943           'unknown-protocol 'major major 'minor minor))
    909944        (or ((car unparsers) response) (loop (cdr unparsers))))))
    910945
     
    9851020         (let loop ((parsers (response-parsers)))
    9861021           (if (null? parsers)
    987                (signal-http-condition "Unknown protocol line" (list line)
    988                                       'unknown-protocol-line 'line line)
     1022               (signal-http-condition
     1023                'read-response "Unknown protocol line" (list line)
     1024                'unknown-protocol-line 'line line)
    9891025               (or ((car parsers) line inport) (loop (cdr parsers))))))))
    9901026
Note: See TracChangeset for help on using the changeset viewer.