scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

move these procs from lib/sunet-utilities to httpd/handler-lib: 

GET-SOCKET-HOST-STRING
GET-NUMERIC-FIELD-VALUE
GET-BODY-LENGTH-FROM-CONTENT-LENGTH
CHUNKED-TRANSFER-CODING?
reason: they are httpd-specific in using httpd's data types
This commit is contained in:
vibr 2005-04-15 15:23:32 +00:00
parent d915722a9b
commit 184c284c4a
3 changed files with 119 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
scheme/httpd/handler-lib.scm Normal file
View File

@ -0,0 +1,91 @@
;;; 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 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)))))

84
scheme/lib/sunet-utilities.scm
View File

@ -5,15 +5,6 @@
;;; For copyright information, see the file COPYING which comes with ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; 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))))))
;;; interpolate hostname or IP address from socket local address. return a string ;;; interpolate hostname or IP address from socket local address. return a string
(define (host-name-or-ip addr) (define (host-name-or-ip addr)
(with-fatal-error-handler (with-fatal-error-handler
@ -81,78 +72,3 @@
(define (get-header headers tag) (define (get-header headers tag)
(cond ((assq tag headers) => cdr) (cond ((assq tag headers) => cdr)
(else #f))) (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"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 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)))))

38
scheme/packages.scm
View File

@ -239,17 +239,14 @@
format-port)) format-port))
(define-interface sunet-utilities-interface (define-interface sunet-utilities-interface
(export get-socket-host-string (export host-name-or-ip
host-name-or-ip
on-interrupt on-interrupt
socket-address->string socket-address->string
dump dump
copy-inport->outport copy-inport->outport
dotdot-check dotdot-check
with-lock with-lock
get-header get-header))
get-body-length-from-content-length
chunked-transfer-coding?))
(define-interface handle-fatal-error-interface (define-interface handle-fatal-error-interface
(export with-fatal-error-handler* (export with-fatal-error-handler*
@ -361,6 +358,12 @@
make-error-response make-error-response
make-redirect-response)) make-redirect-response))
(define-interface httpd-handler-lib-interface
(export get-socket-host-string
get-numeric-field-value
get-body-length-from-content-length
chunked-transfer-coding?))
(define-interface httpd-basic-handlers-interface (define-interface httpd-basic-handlers-interface
(export make-predicate-handler (export make-predicate-handler
make-path-predicate-handler make-path-predicate-handler
@ -586,14 +589,11 @@
(open scheme-with-scsh (open scheme-with-scsh
format-net format-net
sigevents sigevents
(subset srfi-13 (string-join string-skip string-trim-both string-trim string-prefix? string-reverse string-contains string-take)) (subset srfi-13 (string-join string-skip string-trim-both))
dns dns
let-opt ; :optional let-opt ; :optional
locks locks
handle-fatal-error handle-fatal-error)
httpd-errors
httpd-requests
httpd-responses)
(files (lib sunet-utilities))) (files (lib sunet-utilities)))
(define-structure handle-fatal-error handle-fatal-error-interface (define-structure handle-fatal-error handle-fatal-error-interface
@ -649,6 +649,7 @@
httpd-logging httpd-logging
httpd-requests httpd-requests
httpd-responses httpd-responses
httpd-handler-lib
sunet-version sunet-version
) )
@ -720,6 +721,20 @@
httpd-read-options) httpd-read-options)
(files (httpd response))) (files (httpd response)))
(define-structure httpd-handler-lib httpd-handler-lib-interface
(open scheme-with-scsh
format-net
; sigevents
(subset srfi-13 (string-trim-both string-trim string-prefix? string-reverse string-contains string-take))
; let-opt ; :optional
; locks
; handle-fatal-error
sunet-utilities
httpd-requests
httpd-responses
httpd-errors)
(files (httpd handler-lib)))
(define-structure httpd-basic-handlers httpd-basic-handlers-interface (define-structure httpd-basic-handlers httpd-basic-handlers-interface
(open scheme-with-scsh (open scheme-with-scsh
rfc822 rfc822
@ -739,6 +754,7 @@
httpd-requests httpd-requests
httpd-responses httpd-responses
httpd-errors httpd-errors
httpd-handler-lib
httpd-basic-handlers httpd-basic-handlers
httpd-read-options httpd-read-options
url url
@ -759,6 +775,7 @@
httpd-requests ; v0.9-request httpd-requests ; v0.9-request
httpd-responses httpd-responses
httpd-logging ; http-log httpd-logging ; http-log
httpd-handler-lib
htmlout ; Formatted HTML output htmlout ; Formatted HTML output
pp pp
(subset srfi-13 (string-skip)) (subset srfi-13 (string-skip))
@ -816,6 +833,7 @@
httpd-responses httpd-responses
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
httpd-errors ; HTTP-ERROR httpd-errors ; HTTP-ERROR
httpd-handler-lib
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
sunet-version sunet-version
formats formats