sunet/scheme/httpd/handler-lib.scm

;;; A library of procs for handlers.

;;; This file is part of the Scheme Untergrund Networking package.

;;; For copyright information, see the file COPYING which comes with
;;; the distribution.


;; 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))))))


;; 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 (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits, and at least one digit.
	      field-value
	      (http-error 
	       (status-code bad-request) req
	       (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?)

;;get request's message-body length from Content-length: header or
;;throw http-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
	(http-error (status-code bad-request) req "No Content-Length header in request"))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Decode chunked entity bodies: "chunked transfer-coding"


;;; See RFC 2616, 3.6.1 and 19.4.6 for the composition of chunked entity bodies.
;;; See RFC 2616, 4.4 for precedence of Transfer-encoding header over Content-length header.


;;; 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)))))