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