sunet/scheme/lib/sunet-utilities.scm

; some useful utilities

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

;;; Copyright (c) 2002 by Andreas Bernauer.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

(define (host-name-or-ip addr)
  (with-fatal-error-handler
   (lambda (condition more)
     (call-with-values
      (lambda () (socket-address->internet-address addr))
      (lambda (ip port)
	(format-internet-host-address ip))))
   (host-info:name (host-info addr))))

(define (on-interrupt interrupt thunk)
  (let lp ((event (most-recent-sigevent)))
    (let ((next (next-sigevent event interrupt)))
      (thunk)
      (lp next))))

(define (socket-address->string socket-address . with-port?)
  (let ((with-port? (:optional with-port? #t)))
    (receive (host-address service-port)
	     (socket-address->internet-address socket-address)
	     (if with-port?
		 (format #f "~A:~A"
			 (format-internet-host-address host-address)
			 (format-port service-port))
		 (format #f "~A"
			 (format-internet-host-address host-address))))))


;;; Assemble a filename from ROOT and the elts of PATH-LIST.
;;; If the assembled filename contains a .. subdirectory, return #f,
;;; otw return the filename.

(define dotdot-check
  (let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)")))	; Matches a .. subdir.
    (lambda (root path-list)
      (let ((fname (if (null? path-list) root	; Bogus hack.
		       (string-append (file-name-as-directory root)
				      (string-join path-list "/")))))
	(and (not (regexp-exec dotdot-re fname))	; Check for .. subdir.
	     fname)))))

;;; Timeout on network writes?

(define (copy-inport->outport in out . maybe-buffer-size)
  (let* ((buffer-size (:optional maybe-buffer-size 1024))
	 (buf (make-string buffer-size)))
    (let loop ()
      (cond ((read-string! buf in) => (lambda (nchars)
					(write-string buf out 0 nchars)
					(loop)))))
    (force-output out)))

(define (dump fd)
  (copy-inport->outport fd (current-output-port)))

(define (with-lock lock thunk)
  (dynamic-wind 
   (lambda ()
     (obtain-lock lock))
   thunk
   (lambda ()
     (release-lock lock))))

;; Get Header from (RFC822 like) header alist
(define (get-header headers tag)
  (cond ((assq tag headers) => cdr)
	(else #f)))


;; 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,
;; if there is one, check wether its field-content conforms to 
;; field-content = *LWS 1*DIGIT *LWS
;; (i.e. optional leading whitespaces, at least one digit, optional trailing whitespace);
;; if so, return digit as a number

(define (get-numeric-field-value req field-name)
  (let 
      ;;take first Content-length: header (RFC 2616 allows only one Content-length: header)
      ((field-content (get-header (request-headers req) field-name)))
    (if field-content
	(let*
	    ((field-value-start (string-skip field-content char-set:whitespace));; skip whitespace, ;;char-set:whitespace = LWS from RFC2616?
	     (field-value (if field-value-start			;;yes, field content contained non-whitespace chars
			      (string->number (substring field-content   
							 field-value-start
							 (string-length field-content))) ;;trailing whitespace? RFC allows it! ->
			      ;; probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?*
			      (http-error (status-code bad-request) req 
					  (format #f "~A header contained only whitespace" field-name)))))
	  (if (and (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits
	      field-value
	      (http-error (status-code bad-request) req
			  (format #f "~A header contained characters other than 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.


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