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
parent
d915722a9b
commit
184c284c4a
|
|
@ -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)))))
|
||||
|
|
@ -5,15 +5,6 @@
|
|||
;;; 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))))))
|
||||
|
||||
;;; interpolate hostname or IP address from socket local address. return a string
|
||||
(define (host-name-or-ip addr)
|
||||
(with-fatal-error-handler
|
||||
|
|
@ -81,78 +72,3 @@
|
|||
(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"))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; 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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -239,17 +239,14 @@
|
|||
format-port))
|
||||
|
||||
(define-interface sunet-utilities-interface
|
||||
(export get-socket-host-string
|
||||
host-name-or-ip
|
||||
(export host-name-or-ip
|
||||
on-interrupt
|
||||
socket-address->string
|
||||
dump
|
||||
copy-inport->outport
|
||||
dotdot-check
|
||||
with-lock
|
||||
get-header
|
||||
get-body-length-from-content-length
|
||||
chunked-transfer-coding?))
|
||||
get-header))
|
||||
|
||||
(define-interface handle-fatal-error-interface
|
||||
(export with-fatal-error-handler*
|
||||
|
|
@ -361,6 +358,12 @@
|
|||
make-error-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
|
||||
(export make-predicate-handler
|
||||
make-path-predicate-handler
|
||||
|
|
@ -586,14 +589,11 @@
|
|||
(open scheme-with-scsh
|
||||
format-net
|
||||
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
|
||||
let-opt ; :optional
|
||||
locks
|
||||
handle-fatal-error
|
||||
httpd-errors
|
||||
httpd-requests
|
||||
httpd-responses)
|
||||
handle-fatal-error)
|
||||
(files (lib sunet-utilities)))
|
||||
|
||||
(define-structure handle-fatal-error handle-fatal-error-interface
|
||||
|
|
@ -649,6 +649,7 @@
|
|||
httpd-logging
|
||||
httpd-requests
|
||||
httpd-responses
|
||||
httpd-handler-lib
|
||||
|
||||
sunet-version
|
||||
)
|
||||
|
|
@ -720,6 +721,20 @@
|
|||
httpd-read-options)
|
||||
(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
|
||||
(open scheme-with-scsh
|
||||
rfc822
|
||||
|
|
@ -739,6 +754,7 @@
|
|||
httpd-requests
|
||||
httpd-responses
|
||||
httpd-errors
|
||||
httpd-handler-lib
|
||||
httpd-basic-handlers
|
||||
httpd-read-options
|
||||
url
|
||||
|
|
@ -759,6 +775,7 @@
|
|||
httpd-requests ; v0.9-request
|
||||
httpd-responses
|
||||
httpd-logging ; http-log
|
||||
httpd-handler-lib
|
||||
htmlout ; Formatted HTML output
|
||||
pp
|
||||
(subset srfi-13 (string-skip))
|
||||
|
|
@ -816,6 +833,7 @@
|
|||
httpd-responses
|
||||
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
||||
httpd-errors ; HTTP-ERROR
|
||||
httpd-handler-lib
|
||||
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
|
||||
sunet-version
|
||||
formats
|
||||
|
|
|
|||
Loading…
Reference in New Issue