196 lines
8.3 KiB
Scheme
196 lines
8.3 KiB
Scheme
;;; A library of procs for request handlers.
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Reading in the message body of a request.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Read in the message body of an HTTP message and return it as a string.
|
|
;;;
|
|
;;; READ-MESSAGE-BODY handles ordinary message bodies as well as
|
|
;;; message bodies to which the transfer coding "chunked" has been
|
|
;;; applied.
|
|
;;;
|
|
;;; Note: all request handlers should use READ-MESSAGE-BODY, and should not
|
|
;;; read in message bodies by themselves: READ-MESSAGE-BODY implements
|
|
;;; the correct order in which a message body's length is determined.
|
|
;;; (See RFC 2616, 4.4 for precedence of Transfer-encoding header over Content-length header.)
|
|
|
|
(define (read-message-body req)
|
|
(let ((inport (socket:inport (request-socket req))))
|
|
(if (chunked-transfer-coding? req)
|
|
(read-chunked-body inport)
|
|
(read-ordinary-body inport req))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Reading in ordinary bodies (no transfer coding applied)
|
|
|
|
|
|
;;; Read in the message body, return it as a string.
|
|
|
|
(define (read-ordinary-body inport req)
|
|
(let* ((body-length (get-body-length-from-content-length req)) ;make sure we have a valid Content-length header in request
|
|
(maybe-body (read-string body-length inport)))
|
|
(or maybe-body
|
|
(fatal-syntax-error "EOF while reading in message body"))))
|
|
|
|
|
|
;;Get length of the request's message body from Content-length header or
|
|
;;throw fatal-syntax-error if no such header
|
|
|
|
(define (get-body-length-from-content-length req)
|
|
(let
|
|
;;try to get field value of first Content-length header (RFC 2616 allows only one Content-length: header)
|
|
((maybe-length (get-numeric-field-value req 'content-length)))
|
|
(or maybe-length
|
|
(fatal-syntax-error "No Content-Length header in request"))))
|
|
|
|
|
|
;; GET-NUMERIC-FIELD-VALUE
|
|
;; generalized function to get a field value of the form 1*DIGIT
|
|
;; req is a request record, field-name a symbol
|
|
|
|
;; check wether a header-field with name field-name is contained in req;
|
|
;; if not, return #f,
|
|
;; else, take the first such header field and check wether its field-content conforms to
|
|
;; field-content = *LWS 1*DIGIT *LWS
|
|
;; if so, return digit as a number
|
|
|
|
(define (get-numeric-field-value req field-name)
|
|
(let
|
|
;;try to get first "field-name" header
|
|
((field-content (get-header (request-headers req) field-name)))
|
|
(if field-content ;; request contained "field-name" header
|
|
(let ;;see * below
|
|
((field-value (string->number (string-trim-both field-content char-set:blank)))) ;;char-set:blank = Space + Tab = LWS from RFC2616 after folding
|
|
(if (and field-value (>= field-value 0)) ;;yes, field value contained only digits.
|
|
field-value
|
|
(fatal-syntax-error
|
|
(format #f
|
|
"~A header contained only whitespace, or characters other than digits, or whitespace between digits"
|
|
field-name))))
|
|
#f)))
|
|
;;* RFC 2616, 4.2: The field-content does not include any leading or
|
|
;;trailing LWS: linear white space occurring before the first
|
|
;;non-whitespace character of the field-value or after the last
|
|
;;non-whitespace character of the field-value. Such leading or
|
|
;;trailing LWS MAY be removed without changing the semantics of the
|
|
;;field value.
|
|
;;(probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?)
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Decoding chunked entity bodies: "chunked transfer-coding"
|
|
|
|
|
|
;;; Is the request's entity body sent in chunked transfer-encoding?
|
|
;;; (See RFC 2616, 14.41 and 3.6 for syntax and semantics of Transfer-Encoding header.)
|
|
|
|
(define (chunked-transfer-coding? req)
|
|
(let ((field-value (get-header (request-headers req) 'transfer-encoding)))
|
|
(if (not field-value)
|
|
#f
|
|
|
|
; the field value is a comma-separated list of transfer-codings (3.6),
|
|
; extract the last transfer-coding in the list
|
|
(let* ((reversed-field-value (string-reverse field-value))
|
|
(index ; does the list contain more than one element?
|
|
(string-contains reversed-field-value " ,"))
|
|
(last-transfer-coding
|
|
(if index
|
|
(string-trim (string-reverse (string-take reversed-field-value index)))
|
|
(string-trim field-value))))
|
|
|
|
; the first token of the (extracted last) transfer-coding must be "chunked" to indicate chunked transfer coding
|
|
(string-prefix? "chunked" last-transfer-coding)))))
|
|
|
|
|
|
|
|
;;; Read in the chunked entity body, return it as a string.
|
|
;;; (See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.)
|
|
|
|
(define (read-chunked-body inport)
|
|
(let read-chunks ((chunk-size (get-chunk-size inport))
|
|
(res ""))
|
|
(if (= 0 chunk-size) ;last-chunk
|
|
(begin (read-and-discard-trailer inport); see comment *1
|
|
res)
|
|
(let ((maybe-chunk-data (read-string chunk-size inport)))
|
|
(if maybe-chunk-data
|
|
(begin (discard-line-terminator inport)
|
|
(read-chunks (get-chunk-size inport) (string-append res maybe-chunk-data)))
|
|
(fatal-syntax-error "EOF while reading in chunk-data in chunked entity body"))))))
|
|
|
|
;comment *1:
|
|
;
|
|
;This is were we don't achieve conditional compliance: we ought to read
|
|
;in the entity-headers in the trailer and incorporate them into the
|
|
;request record. Within our current scheme (where reading in the
|
|
;entity-body is the request-handlers job - while the request-handler
|
|
;is only called _after_ the request record has been built) this is not
|
|
;possible.
|
|
;
|
|
;Note that in their current state (04/2005) the handlers actually
|
|
;disregard most request headers anyway (even the request headers
|
|
;parsed into the request record).
|
|
;
|
|
;Alternatively we could check the request for a Trailer header and
|
|
;respond with 500 if we find one. Problem here: the clients "SHOULD
|
|
;include a Trailer header field in a message using chunked
|
|
;transfer-coding with a non-empty trailer" (14.40) - they are not
|
|
;obliged to! So even if we check for a Trailer header we may still
|
|
;silently disregard a trailer.
|
|
|
|
|
|
;;;Read in a chunk-size line within a chunked entity body; return the chunk-size as an integer.
|
|
;;; (See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.)
|
|
|
|
(define (get-chunk-size inport)
|
|
(let ((chunk-size-line (read-crlf-line inport)))
|
|
(if (eof-object? chunk-size-line)
|
|
(fatal-syntax-error "EOF while reading in chunk-size in chunked entity body")
|
|
(let* ((chunk-extensions-index (string-contains chunk-size-line "; "))
|
|
(hex-string (if chunk-extensions-index
|
|
(string-take chunk-size-line chunk-extensions-index)
|
|
chunk-size-line))
|
|
(chunk-size-int (string->number (string-trim-both hex-string char-set:blank) 16)))
|
|
(if (and chunk-size-int (>= chunk-size-int 0)) ; yes, chunk-size contained only hex chars
|
|
chunk-size-int
|
|
(fatal-syntax-error "Chunk-size within chunked entity body is incorrect or syntactically faulty"))))))
|
|
|
|
(define (read-and-discard-trailer inport)
|
|
(with-fatal-error-handler
|
|
(lambda (c decline)
|
|
(fatal-syntax-error "Illegal RFC 822 field syntax within trailer of entity message body"))
|
|
(read-rfc822-headers inport)))
|
|
|
|
(define (discard-line-terminator inport)
|
|
(read-char inport) (read-char inport)) ;;assuming the line terminator is CRLF as required by RFC 2616
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Misc
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;; interpolate host info from our request's net connection.
|
|
;; return string. Example: "134.2.12.72:7777"
|
|
(define (get-socket-host-string req)
|
|
(let ((addr (socket-local-address (request-socket req))))
|
|
(call-with-values
|
|
(lambda ()(socket-address->internet-address addr))
|
|
(lambda (ipaddr portnum)
|
|
(string-append (format-internet-host-address ipaddr) ":" (number->string portnum))))))
|