124 lines
4.4 KiB
Scheme
124 lines
4.4 KiB
Scheme
; 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"))))
|
|
|