* split up big httpd-core file in several pieces
* make structures that used httpd-core using the new pieces of httpd-core
This commit is contained in:
parent
a4eec0ffb8
commit
77ebc6aea4
240
modules.scm
240
modules.scm
|
@ -513,91 +513,32 @@
|
||||||
;;; httpd-core
|
;;; httpd-core
|
||||||
|
|
||||||
(define-interface httpd-core-interface
|
(define-interface httpd-core-interface
|
||||||
(export server/version
|
(export httpd
|
||||||
server/protocol
|
|
||||||
|
|
||||||
http-syslog
|
|
||||||
http-log
|
|
||||||
http-syslog
|
|
||||||
|
|
||||||
httpd
|
|
||||||
|
|
||||||
make-request ; HTTP request
|
|
||||||
request? ; record type.
|
|
||||||
request:method
|
|
||||||
request:uri
|
|
||||||
request:url
|
|
||||||
request:version
|
|
||||||
request:headers
|
|
||||||
request:socket
|
|
||||||
set-request:method
|
|
||||||
set-request:uri
|
|
||||||
set-request:url
|
|
||||||
set-request:version
|
|
||||||
set-request:headers
|
|
||||||
set-request:socket
|
|
||||||
|
|
||||||
version< version<=
|
|
||||||
v0.9-request?
|
|
||||||
version->string
|
|
||||||
|
|
||||||
;; Integer reply codes
|
|
||||||
reply-code->text
|
|
||||||
http-reply/ok
|
|
||||||
http-reply/created
|
|
||||||
http-reply/accepted
|
|
||||||
http-reply/prov-info
|
|
||||||
http-reply/no-content
|
|
||||||
http-reply/mult-choice
|
|
||||||
http-reply/moved-perm
|
|
||||||
http-reply/moved-temp
|
|
||||||
http-reply/method
|
|
||||||
http-reply/not-mod
|
|
||||||
http-reply/bad-request
|
|
||||||
http-reply/unauthorized
|
|
||||||
http-reply/payment-req
|
|
||||||
http-reply/forbidden
|
|
||||||
http-reply/not-found
|
|
||||||
http-reply/method-not-allowed
|
|
||||||
http-reply/none-acceptable
|
|
||||||
http-reply/proxy-auth-required
|
|
||||||
http-reply/timeout
|
|
||||||
http-reply/conflict
|
|
||||||
http-reply/gone
|
|
||||||
http-reply/internal-error
|
|
||||||
http-reply/not-implemented
|
|
||||||
http-reply/bad-gateway
|
|
||||||
http-reply/service-unavailable
|
|
||||||
http-reply/gateway-timeout
|
|
||||||
|
|
||||||
time->http-date-string
|
|
||||||
begin-http-header
|
|
||||||
send-http-error-reply))
|
send-http-error-reply))
|
||||||
|
|
||||||
(define-structure httpd-core httpd-core-interface
|
(define-structure httpd-core httpd-core-interface
|
||||||
(open threads locks
|
(open thread-fluids ; fork-thread
|
||||||
thread-fluids ; fork-thread
|
|
||||||
scsh
|
scsh
|
||||||
receiving
|
receiving ; receive
|
||||||
crlf-io
|
crlf-io ; write-crlf, read-crlf-line
|
||||||
rfc822
|
rfc822 ; read-rfc822-headers
|
||||||
char-set-lib
|
char-set-lib ; char-set-complement, char-set:whitespace
|
||||||
defrec-package
|
handle ; ignore-errors
|
||||||
define-record-types
|
conditions ; condition-stuff
|
||||||
handle
|
|
||||||
conditions ; condition-stuff
|
|
||||||
defenum-package
|
|
||||||
httpd-error
|
|
||||||
handle-fatal-error
|
|
||||||
uri
|
uri
|
||||||
url
|
url
|
||||||
formats
|
formats ; format
|
||||||
format-net
|
format-net ; format-internet-host-address
|
||||||
sunet-utilities
|
rate-limit ; rate-limiting stuff
|
||||||
|
string-lib ; STRING-INDEX
|
||||||
|
|
||||||
|
handle-fatal-error
|
||||||
httpd-read-options
|
httpd-read-options
|
||||||
rate-limit
|
httpd-error
|
||||||
string-lib ; STRING-JOIN
|
httpd-logging
|
||||||
i/o ; make-null-output-port
|
httpd-request
|
||||||
|
httpd-reply-codes
|
||||||
|
httpd-text-generation
|
||||||
scheme)
|
scheme)
|
||||||
(files (httpd core)))
|
(files (httpd core)))
|
||||||
|
|
||||||
|
@ -644,7 +585,8 @@
|
||||||
|
|
||||||
(define-structure httpd-access-control httpd-access-control-interface
|
(define-structure httpd-access-control httpd-access-control-interface
|
||||||
(open big-scheme
|
(open big-scheme
|
||||||
httpd-core
|
httpd-reply-codes
|
||||||
|
httpd-request
|
||||||
httpd-error
|
httpd-error
|
||||||
string-lib ; STRING-MAP
|
string-lib ; STRING-MAP
|
||||||
scsh
|
scsh
|
||||||
|
@ -674,6 +616,119 @@
|
||||||
(open scheme conditions handle)
|
(open scheme conditions handle)
|
||||||
(files (httpd handle-fatal-error)))
|
(files (httpd handle-fatal-error)))
|
||||||
|
|
||||||
|
;;; httpd-logging
|
||||||
|
|
||||||
|
(define-interface httpd-logging-interface
|
||||||
|
(export init-http-log!
|
||||||
|
*http-syslog?*
|
||||||
|
http-syslog
|
||||||
|
http-log))
|
||||||
|
|
||||||
|
(define-structure httpd-logging httpd-logging-interface
|
||||||
|
(open httpd-read-options
|
||||||
|
i/o ; make-null-output-port
|
||||||
|
locks ; make-lock obtain-lock release-lock
|
||||||
|
receiving ; receive
|
||||||
|
uri ; uri-path-list->path
|
||||||
|
url ; http-url:path
|
||||||
|
httpd-request ; request record
|
||||||
|
formats ; format
|
||||||
|
format-net ; format-internet-host-address
|
||||||
|
string-lib ; string-join, string-trim
|
||||||
|
rfc822 ; get-header
|
||||||
|
sunet-utilities ; on-interrupt
|
||||||
|
threads ; spawn
|
||||||
|
scsh
|
||||||
|
scheme)
|
||||||
|
(files (httpd logging)))
|
||||||
|
|
||||||
|
;; httpd-reply-codes
|
||||||
|
|
||||||
|
(define-interface httpd-reply-codes-interface
|
||||||
|
(export ;; Integer reply codes
|
||||||
|
reply-code->text
|
||||||
|
http-reply/ok
|
||||||
|
http-reply/created
|
||||||
|
http-reply/accepted
|
||||||
|
http-reply/prov-info
|
||||||
|
http-reply/no-content
|
||||||
|
http-reply/mult-choice
|
||||||
|
http-reply/moved-perm
|
||||||
|
http-reply/moved-temp
|
||||||
|
http-reply/method
|
||||||
|
http-reply/not-mod
|
||||||
|
http-reply/bad-request
|
||||||
|
http-reply/unauthorized
|
||||||
|
http-reply/payment-req
|
||||||
|
http-reply/forbidden
|
||||||
|
http-reply/not-found
|
||||||
|
http-reply/method-not-allowed
|
||||||
|
http-reply/none-acceptable
|
||||||
|
http-reply/proxy-auth-required
|
||||||
|
http-reply/timeout
|
||||||
|
http-reply/conflict
|
||||||
|
http-reply/gone
|
||||||
|
http-reply/internal-error
|
||||||
|
http-reply/not-implemented
|
||||||
|
http-reply/bad-gateway
|
||||||
|
http-reply/service-unavailable
|
||||||
|
http-reply/gateway-timeout))
|
||||||
|
|
||||||
|
(define-structure httpd-reply-codes httpd-reply-codes-interface
|
||||||
|
(open defenum-package
|
||||||
|
scheme)
|
||||||
|
(files (httpd reply-codes)))
|
||||||
|
|
||||||
|
;; httpd-request
|
||||||
|
|
||||||
|
(define-interface httpd-request-interface
|
||||||
|
(export make-request ; HTTP request
|
||||||
|
request? ; record type.
|
||||||
|
request:method
|
||||||
|
request:uri
|
||||||
|
request:url
|
||||||
|
request:version
|
||||||
|
request:headers
|
||||||
|
request:socket
|
||||||
|
set-request:method
|
||||||
|
set-request:uri
|
||||||
|
set-request:url
|
||||||
|
set-request:version
|
||||||
|
set-request:headers
|
||||||
|
set-request:socket
|
||||||
|
|
||||||
|
version< version<=
|
||||||
|
v0.9-request?
|
||||||
|
version->string))
|
||||||
|
|
||||||
|
(define-structure httpd-request httpd-request-interface
|
||||||
|
(open define-record-types ;; define-record-discloser
|
||||||
|
defrec-package ;; define-record
|
||||||
|
scheme)
|
||||||
|
(files (httpd request)))
|
||||||
|
|
||||||
|
(define-interface httpd-constants-interface
|
||||||
|
(export server/version
|
||||||
|
server/protocol))
|
||||||
|
|
||||||
|
(define-structure httpd-constants httpd-constants-interface
|
||||||
|
(open scheme)
|
||||||
|
(files (httpd constants)))
|
||||||
|
|
||||||
|
(define-interface httpd-text-generation-interface
|
||||||
|
(export time->http-date-string
|
||||||
|
begin-http-header
|
||||||
|
title-html))
|
||||||
|
|
||||||
|
(define-structure httpd-text-generation httpd-text-generation-interface
|
||||||
|
(open formats
|
||||||
|
httpd-reply-codes ; reply-code->text
|
||||||
|
crlf-io
|
||||||
|
httpd-constants
|
||||||
|
scheme
|
||||||
|
scsh) ; format-date
|
||||||
|
(files (httpd text-generation)))
|
||||||
|
|
||||||
|
|
||||||
;; path-handlers
|
;; path-handlers
|
||||||
|
|
||||||
|
@ -698,9 +753,10 @@
|
||||||
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
||||||
(open scsh ; syscalls
|
(open scsh ; syscalls
|
||||||
formats ; FORMAT
|
formats ; FORMAT
|
||||||
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
httpd-request ; REQUEST record type, v0.9-request
|
||||||
; v0.9-request, begin-http-header
|
httpd-reply-codes ; reply codes
|
||||||
httpd-error
|
httpd-text-generation ; begin-http-header
|
||||||
|
httpd-error ; HTTP-ERROR
|
||||||
htmlout
|
htmlout
|
||||||
conditions ; CONDITION-STUFF
|
conditions ; CONDITION-STUFF
|
||||||
url ; HTTP-URL record type
|
url ; HTTP-URL record type
|
||||||
|
@ -718,8 +774,10 @@
|
||||||
(define-structure seval-handler seval-handler-interface
|
(define-structure seval-handler seval-handler-interface
|
||||||
(open scsh ; syscalls & INDEX
|
(open scsh ; syscalls & INDEX
|
||||||
httpd-error
|
httpd-error
|
||||||
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
httpd-request ; v0.9-request
|
||||||
; v0.9-request, reply formatting stuff.
|
httpd-reply-codes
|
||||||
|
httpd-text-generation ; begin-http-header
|
||||||
|
httpd-logging ; http-log
|
||||||
uri ; UNESCAPE-URI
|
uri ; UNESCAPE-URI
|
||||||
htmlout ; Formatted HTML output
|
htmlout ; Formatted HTML output
|
||||||
error-package ; ERROR
|
error-package ; ERROR
|
||||||
|
@ -747,7 +805,9 @@
|
||||||
string-lib
|
string-lib
|
||||||
conditions signals handle
|
conditions signals handle
|
||||||
htmlout
|
htmlout
|
||||||
httpd-core
|
httpd-request
|
||||||
|
httpd-text-generation
|
||||||
|
httpd-reply-codes
|
||||||
httpd-error
|
httpd-error
|
||||||
url
|
url
|
||||||
uri
|
uri
|
||||||
|
@ -770,7 +830,9 @@
|
||||||
nroff-n-decode))
|
nroff-n-decode))
|
||||||
|
|
||||||
(define-structure rman-gateway rman-gateway-interface
|
(define-structure rman-gateway rman-gateway-interface
|
||||||
(open httpd-core
|
(open httpd-reply-codes
|
||||||
|
httpd-request
|
||||||
|
httpd-text-generation
|
||||||
httpd-error
|
httpd-error
|
||||||
conditions
|
conditions
|
||||||
url
|
url
|
||||||
|
@ -798,8 +860,10 @@
|
||||||
crlf-io ; WRITE-CRLF
|
crlf-io ; WRITE-CRLF
|
||||||
uri
|
uri
|
||||||
url ; HTTP-URL record type
|
url ; HTTP-URL record type
|
||||||
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes
|
httpd-constants
|
||||||
; version stuff
|
httpd-logging
|
||||||
|
httpd-request
|
||||||
|
httpd-reply-codes
|
||||||
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
||||||
httpd-error ; HTTP-ERROR
|
httpd-error ; HTTP-ERROR
|
||||||
scsh-utilities ; INDEX
|
scsh-utilities ; INDEX
|
||||||
|
|
|
@ -0,0 +1,4 @@
|
||||||
|
;;; Constants
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
(define server/version "Scheme-Underground/1.0")
|
||||||
|
(define server/protocol "HTTP/1.0")
|
|
@ -23,150 +23,13 @@
|
||||||
;;; scsh system calls
|
;;; scsh system calls
|
||||||
;;; rfc822 header parsing
|
;;; rfc822 header parsing
|
||||||
;;; crlf-io (read cr/lf terminated lines)
|
;;; crlf-io (read cr/lf terminated lines)
|
||||||
;;; when, unless, switch, ? (conditionals)
|
|
||||||
;;; uri, url packages
|
;;; uri, url packages
|
||||||
;;; defrec package (record structures)
|
|
||||||
;;; defenum (enumerated types)
|
|
||||||
;;; ignore-errors (HANDLE package)
|
;;; ignore-errors (HANDLE package)
|
||||||
;;; string hacking stuff
|
|
||||||
;;; char-set stuff
|
;;; char-set stuff
|
||||||
;;; format (Formatted output)
|
;;; format (Formatted output)
|
||||||
;;; httpd error stuff
|
;;; httpd error stuff
|
||||||
;;; condition-stuff (S48 error conditions)
|
;;; condition-stuff (S48 error conditions)
|
||||||
|
|
||||||
;;; Constants
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(define server/version "Scheme-Underground/1.0")
|
|
||||||
(define server/protocol "HTTP/1.0")
|
|
||||||
|
|
||||||
;; default: no logging
|
|
||||||
;; initialized by init-http-log!
|
|
||||||
|
|
||||||
;; CLF-logging
|
|
||||||
;; if enabled, it will look like this:
|
|
||||||
;; (lambda req reply-code)
|
|
||||||
(define http-log (lambda a #f)) ; makes logging in CLF
|
|
||||||
|
|
||||||
;; syslogging
|
|
||||||
;; if enabled, it will look like this:
|
|
||||||
;; (lambda (level fmt . args)
|
|
||||||
(define http-syslog (lambda a #f)) ; makes syslog
|
|
||||||
(define *http-syslog?* #f) ; trigger used to avoid
|
|
||||||
; unnecessary computations
|
|
||||||
(define *http-log-port*)
|
|
||||||
(define (http-log-port)
|
|
||||||
*http-log-port*)
|
|
||||||
(define (set-http-log-port! port)
|
|
||||||
(set! *http-log-port* port))
|
|
||||||
|
|
||||||
(define (init-http-log! options)
|
|
||||||
;; syslog has to be initialized befor CLF-logging
|
|
||||||
;; because it may generate syslog-messages
|
|
||||||
(init-http-syslog! (httpd-options-syslog? options))
|
|
||||||
(init-http-port-log! (httpd-options-logfile options)))
|
|
||||||
|
|
||||||
(define (init-http-port-log! logfile)
|
|
||||||
(let ((logport
|
|
||||||
(cond
|
|
||||||
((string? logfile) ; try to open logfile for appending (output)
|
|
||||||
(open-logfile logfile))
|
|
||||||
((output-port? logfile) ; we were given an output port, so let's use it
|
|
||||||
logfile)
|
|
||||||
((eq? logfile #f) ; no logging demanded
|
|
||||||
#f)
|
|
||||||
; unexpected value of logfile;
|
|
||||||
(else
|
|
||||||
(http-syslog
|
|
||||||
(syslog-level warning)
|
|
||||||
"[httpd] Warning: Logfile was not specified correctly (given: ~S).~% No CLF logging."
|
|
||||||
logfile)
|
|
||||||
(make-null-output-port)))))
|
|
||||||
|
|
||||||
(if logfile ; if logging was specified, set up the logger
|
|
||||||
(let ((http-log-lock (make-lock)))
|
|
||||||
(set-http-log-port! logport)
|
|
||||||
(if (string? logfile)
|
|
||||||
(spawn (make-logfile-rotator logfile http-log-lock)))
|
|
||||||
(set! http-log (make-http-log-proc http-log-lock))))))
|
|
||||||
; alternative-clause: default values of *http-syslog?* and http-log
|
|
||||||
|
|
||||||
(define (init-http-syslog! syslog?)
|
|
||||||
(if syslog?
|
|
||||||
(let ((http-syslog-lock (make-lock)))
|
|
||||||
(set! *http-syslog?* #t)
|
|
||||||
(set! http-syslog
|
|
||||||
(lambda (level fmt . args)
|
|
||||||
(obtain-lock http-syslog-lock)
|
|
||||||
(syslog level
|
|
||||||
(apply format #f fmt args))
|
|
||||||
(release-lock http-syslog-lock))))))
|
|
||||||
|
|
||||||
(define (make-http-log-proc http-log-lock)
|
|
||||||
; (display "--- MARK (server started) ---\n" http-log-port)
|
|
||||||
(lambda (req reply-code)
|
|
||||||
(if req
|
|
||||||
(begin
|
|
||||||
(obtain-lock http-log-lock)
|
|
||||||
(display (make-CLF
|
|
||||||
(receive (host-address _)
|
|
||||||
(socket-address->internet-address
|
|
||||||
(socket-remote-address (request:socket req)))
|
|
||||||
(format-internet-host-address host-address))
|
|
||||||
(request:method req) ; request method
|
|
||||||
(uri-path-list->path
|
|
||||||
(http-url:path (request:url req))) ; requested file
|
|
||||||
(version->string (request:version req)) ; protocol version
|
|
||||||
reply-code
|
|
||||||
23 ; filesize (unknown)
|
|
||||||
(get-header (request:headers req) 'referer)
|
|
||||||
(get-header (request:headers req) 'user-agent))
|
|
||||||
(http-log-port))
|
|
||||||
(force-output (http-log-port))
|
|
||||||
(release-lock http-log-lock)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; does the logfile rotation on signal USR1
|
|
||||||
(define (make-logfile-rotator logfile http-log-lock)
|
|
||||||
(set-interrupt-handler interrupt/usr1 #f)
|
|
||||||
(lambda ()
|
|
||||||
(on-interrupt
|
|
||||||
interrupt/usr1
|
|
||||||
(lambda ()
|
|
||||||
(obtain-lock http-log-lock)
|
|
||||||
(close-output-port (http-log-port))
|
|
||||||
(set-http-log-port! (open-logfile logfile))
|
|
||||||
(release-lock http-log-lock)))))
|
|
||||||
|
|
||||||
(define (open-logfile logfile)
|
|
||||||
(with-errno-handler*
|
|
||||||
(lambda (errno packet)
|
|
||||||
(http-syslog (syslog-level warning)
|
|
||||||
"[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
|
|
||||||
logfile
|
|
||||||
(car packet))
|
|
||||||
(make-null-output-port))
|
|
||||||
(lambda ()
|
|
||||||
(open-output-file logfile
|
|
||||||
(bitwise-ior open/create open/append)))))
|
|
||||||
|
|
||||||
; returns a string for a CLF entry (Common Log Format)
|
|
||||||
; note: till now, we do not log the user's time zone code
|
|
||||||
(define (make-CLF remote-ip request-type requested-file protocol http-code filesize referer user-agent)
|
|
||||||
(format #f "~A - - ~A ~S ~A ~A ~S ~S~%"
|
|
||||||
(or remote-ip "-")
|
|
||||||
(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date)) ; +0000 as we don't know
|
|
||||||
(string-join (list request-type requested-file protocol))
|
|
||||||
; Unfortunately, we first split the request line into
|
|
||||||
; method/request-type etc. and put it together here.
|
|
||||||
; Files conform to CLF are expected to print the original line.
|
|
||||||
(or http-code "-")
|
|
||||||
(or filesize "-")
|
|
||||||
(if (string? referer) (string-trim referer char-set:whitespace) "")
|
|
||||||
(if (string? user-agent)
|
|
||||||
(string-trim user-agent char-set:whitespace)
|
|
||||||
"")))
|
|
||||||
|
|
||||||
|
|
||||||
;;; (httpd options)
|
;;; (httpd options)
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;; The server top-level. PATH-HANDLER is the top-level request path handler --
|
;;; The server top-level. PATH-HANDLER is the top-level request path handler --
|
||||||
|
@ -301,45 +164,8 @@
|
||||||
|
|
||||||
;;;; HTTP request parsing
|
;;;; HTTP request parsing
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;;; This code defines the http REQUEST data structure, and provides
|
;;;; This code provides procedures to read requests from an input
|
||||||
;;;; code to read requests from an input port.
|
;;;; port.
|
||||||
|
|
||||||
(define-record request
|
|
||||||
method ; A string such as "GET", "PUT", etc.
|
|
||||||
uri ; The escaped URI string as read from request line.
|
|
||||||
url ; An http URL record (see url.scm).
|
|
||||||
version ; A (major . minor) integer pair.
|
|
||||||
headers ; An rfc822 header alist (see rfc822.scm).
|
|
||||||
socket) ; The socket connected to the client.
|
|
||||||
|
|
||||||
(define-record-discloser type/request
|
|
||||||
(lambda (req)
|
|
||||||
(list 'request
|
|
||||||
(request:method req)
|
|
||||||
(request:uri req)
|
|
||||||
(request:url req)
|
|
||||||
(request:version req)
|
|
||||||
(request:headers req)
|
|
||||||
(request:socket req))))
|
|
||||||
;;; A http protocol version is an integer pair: (major . minor).
|
|
||||||
|
|
||||||
(define (version< v1 v2)
|
|
||||||
(or (< (car v1) (car v2))
|
|
||||||
(and (= (car v1) (car v2))
|
|
||||||
(< (cdr v1) (cdr v2)))))
|
|
||||||
|
|
||||||
(define (version<= v1 v2) (not (version< v2 v1)))
|
|
||||||
|
|
||||||
(define (v0.9-request? req)
|
|
||||||
(version<= (request:version req) '(0 . 9)))
|
|
||||||
|
|
||||||
|
|
||||||
(define (version->string v)
|
|
||||||
(string-append "HTTP/"
|
|
||||||
(number->string (car v))
|
|
||||||
"."
|
|
||||||
(number->string (cdr v))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Read and parse an http request from INPORT.
|
;;; Read and parse an http request from INPORT.
|
||||||
;;;
|
;;;
|
||||||
|
@ -443,77 +269,6 @@
|
||||||
(else '()))))
|
(else '()))))
|
||||||
|
|
||||||
|
|
||||||
;;;; Sending replies
|
|
||||||
;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
;;; Reply codes
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;;; (define http-reply/ok 200), etc.
|
|
||||||
;;; Also, build an alist HTTP-REPLY-TEXT-TABLE mapping integer reply codes
|
|
||||||
;;; to their diagnostic text messages.
|
|
||||||
|
|
||||||
(define-syntax define-http-reply-codes
|
|
||||||
(syntax-rules ()
|
|
||||||
((define-http-reply-codes table set (name val msg) ...)
|
|
||||||
(begin (define table '((val . msg) ...))
|
|
||||||
(define-enum-constant set name val)
|
|
||||||
...))))
|
|
||||||
|
|
||||||
(define-http-reply-codes http-reply-text-table http-reply
|
|
||||||
(ok 200 "OK")
|
|
||||||
(created 201 "Created")
|
|
||||||
(accepted 202 "Accepted")
|
|
||||||
(prov-info 203 "Provisional Information")
|
|
||||||
(no-content 204 "No Content")
|
|
||||||
|
|
||||||
(mult-choice 300 "Multiple Choices")
|
|
||||||
(moved-perm 301 "Moved Permanently")
|
|
||||||
(moved-temp 302 "Moved Temporarily")
|
|
||||||
(method 303 "Method (obsolete)")
|
|
||||||
(not-mod 304 "Not Modified")
|
|
||||||
|
|
||||||
(bad-request 400 "Bad Request")
|
|
||||||
(unauthorized 401 "Unauthorized")
|
|
||||||
(payment-req 402 "Payment Required")
|
|
||||||
(forbidden 403 "Forbidden")
|
|
||||||
(not-found 404 "Not Found")
|
|
||||||
(method-not-allowed 405 "Method Not Allowed")
|
|
||||||
(none-acceptable 406 "None Acceptable")
|
|
||||||
(proxy-auth-required 407 "Proxy Authentication Required")
|
|
||||||
(timeout 408 "Request Timeout")
|
|
||||||
(conflict 409 "Conflict")
|
|
||||||
(gone 410 "Gone")
|
|
||||||
|
|
||||||
(internal-error 500 "Internal Server Error")
|
|
||||||
(not-implemented 501 "Not Implemented")
|
|
||||||
(bad-gateway 502 "Bad Gateway")
|
|
||||||
(service-unavailable 503 "Service Unavailable")
|
|
||||||
(gateway-timeout 504 "Gateway Timeout"))
|
|
||||||
|
|
||||||
(define (reply-code->text code)
|
|
||||||
(cdr (assv code http-reply-text-table)))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Text generation utilities.
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(define (time->http-date-string time)
|
|
||||||
(format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
|
||||||
|
|
||||||
;;; Output the first chunk of a reply header.
|
|
||||||
|
|
||||||
(define (begin-http-header out reply-code)
|
|
||||||
(format out "~A ~d ~A\r~%"
|
|
||||||
server/protocol reply-code (reply-code->text reply-code))
|
|
||||||
(format out "Date: ~A\r~%" (time->http-date-string (time)))
|
|
||||||
(format out "Server: ~A\r~%" server/version))
|
|
||||||
|
|
||||||
(define (title-html out message new-protocol?)
|
|
||||||
(if new-protocol? (write-crlf out)) ; Separate html from headers.
|
|
||||||
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
|
|
||||||
(format out "<BODY>~%<H1>~A</H1>~%" message))
|
|
||||||
|
|
||||||
|
|
||||||
;;; (send-http-error-reply reply-code req options [message . extras])
|
;;; (send-http-error-reply reply-code req options [message . extras])
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;; Take an http-error condition, and format it into a reply to the client.
|
;;; Take an http-error condition, and format it into a reply to the client.
|
||||||
|
|
|
@ -0,0 +1,132 @@
|
||||||
|
;;; logging.scm
|
||||||
|
;;; logging functionality for web server
|
||||||
|
;;; 2002, Andreas Bernauer, Martin Gasbichler
|
||||||
|
|
||||||
|
;; default: no logging
|
||||||
|
;; initialized by init-http-log!
|
||||||
|
|
||||||
|
;; CLF-logging
|
||||||
|
;; if enabled, it will look like this:
|
||||||
|
;; (lambda req reply-code)
|
||||||
|
(define http-log (lambda a #f)) ; makes logging in CLF
|
||||||
|
|
||||||
|
;; syslogging
|
||||||
|
;; if enabled, it will look like this:
|
||||||
|
;; (lambda (level fmt . args)
|
||||||
|
(define http-syslog (lambda a #f)) ; makes syslog
|
||||||
|
(define *http-syslog?* #f) ; trigger used to avoid
|
||||||
|
; unnecessary computations
|
||||||
|
(define *http-log-port*)
|
||||||
|
(define (http-log-port)
|
||||||
|
*http-log-port*)
|
||||||
|
(define (set-http-log-port! port)
|
||||||
|
(set! *http-log-port* port))
|
||||||
|
|
||||||
|
(define (init-http-log! options)
|
||||||
|
;; syslog has to be initialized befor CLF-logging
|
||||||
|
;; because it may generate syslog-messages
|
||||||
|
(init-http-syslog! (httpd-options-syslog? options))
|
||||||
|
(init-http-port-log! (httpd-options-logfile options)))
|
||||||
|
|
||||||
|
(define (init-http-port-log! logfile)
|
||||||
|
(let ((logport
|
||||||
|
(cond
|
||||||
|
((string? logfile) ; try to open logfile for appending (output)
|
||||||
|
(open-logfile logfile))
|
||||||
|
((output-port? logfile) ; we were given an output port, so let's use it
|
||||||
|
logfile)
|
||||||
|
((eq? logfile #f) ; no logging demanded
|
||||||
|
#f)
|
||||||
|
; unexpected value of logfile;
|
||||||
|
(else
|
||||||
|
(http-syslog
|
||||||
|
(syslog-level warning)
|
||||||
|
"[httpd] Warning: Logfile was not specified correctly (given: ~S).~% No CLF logging."
|
||||||
|
logfile)
|
||||||
|
(make-null-output-port)))))
|
||||||
|
|
||||||
|
(if logfile ; if logging was specified, set up the logger
|
||||||
|
(let ((http-log-lock (make-lock)))
|
||||||
|
(set-http-log-port! logport)
|
||||||
|
(if (string? logfile)
|
||||||
|
(spawn (make-logfile-rotator logfile http-log-lock)))
|
||||||
|
(set! http-log (make-http-log-proc http-log-lock))))))
|
||||||
|
; alternative-clause: default values of *http-syslog?* and http-log
|
||||||
|
|
||||||
|
(define (init-http-syslog! syslog?)
|
||||||
|
(if syslog?
|
||||||
|
(let ((http-syslog-lock (make-lock)))
|
||||||
|
(set! *http-syslog?* #t)
|
||||||
|
(set! http-syslog
|
||||||
|
(lambda (level fmt . args)
|
||||||
|
(obtain-lock http-syslog-lock)
|
||||||
|
(syslog level
|
||||||
|
(apply format #f fmt args))
|
||||||
|
(release-lock http-syslog-lock))))))
|
||||||
|
|
||||||
|
(define (make-http-log-proc http-log-lock)
|
||||||
|
; (display "--- MARK (server started) ---\n" http-log-port)
|
||||||
|
(lambda (req reply-code)
|
||||||
|
(if req
|
||||||
|
(begin
|
||||||
|
(obtain-lock http-log-lock)
|
||||||
|
(display (make-CLF
|
||||||
|
(receive (host-address _)
|
||||||
|
(socket-address->internet-address
|
||||||
|
(socket-remote-address (request:socket req)))
|
||||||
|
(format-internet-host-address host-address))
|
||||||
|
(request:method req) ; request method
|
||||||
|
(uri-path-list->path
|
||||||
|
(http-url:path (request:url req))) ; requested file
|
||||||
|
(version->string (request:version req)) ; protocol version
|
||||||
|
reply-code
|
||||||
|
23 ; filesize (unknown)
|
||||||
|
(get-header (request:headers req) 'referer)
|
||||||
|
(get-header (request:headers req) 'user-agent))
|
||||||
|
(http-log-port))
|
||||||
|
(force-output (http-log-port))
|
||||||
|
(release-lock http-log-lock)))))
|
||||||
|
|
||||||
|
|
||||||
|
;; does the logfile rotation on signal USR1
|
||||||
|
(define (make-logfile-rotator logfile http-log-lock)
|
||||||
|
(set-interrupt-handler interrupt/usr1 #f)
|
||||||
|
(lambda ()
|
||||||
|
(on-interrupt
|
||||||
|
interrupt/usr1
|
||||||
|
(lambda ()
|
||||||
|
(obtain-lock http-log-lock)
|
||||||
|
(close-output-port (http-log-port))
|
||||||
|
(set-http-log-port! (open-logfile logfile))
|
||||||
|
(release-lock http-log-lock)))))
|
||||||
|
|
||||||
|
(define (open-logfile logfile)
|
||||||
|
(with-errno-handler*
|
||||||
|
(lambda (errno packet)
|
||||||
|
(http-syslog (syslog-level warning)
|
||||||
|
"[httpd] Warning: An error occured while opening ~S for writing (~A).~%Send signal USR1 when the problem is fixed.~%"
|
||||||
|
logfile
|
||||||
|
(car packet))
|
||||||
|
(make-null-output-port))
|
||||||
|
(lambda ()
|
||||||
|
(open-output-file logfile
|
||||||
|
(bitwise-ior open/create open/append)))))
|
||||||
|
|
||||||
|
; returns a string for a CLF entry (Common Log Format)
|
||||||
|
; note: till now, we do not log the user's time zone code
|
||||||
|
(define (make-CLF remote-ip request-type requested-file protocol http-code filesize referer user-agent)
|
||||||
|
(format #f "~A - - ~A ~S ~A ~A ~S ~S~%"
|
||||||
|
(or remote-ip "-")
|
||||||
|
(format-date "[~d/~b/~Y:~H:~M:~S +0000]" (date)) ; +0000 as we don't know
|
||||||
|
(string-join (list request-type requested-file protocol))
|
||||||
|
; Unfortunately, we first split the request line into
|
||||||
|
; method/request-type etc. and put it together here.
|
||||||
|
; Files conform to CLF are expected to print the original line.
|
||||||
|
(or http-code "-")
|
||||||
|
(or filesize "-")
|
||||||
|
(if (string? referer) (string-trim referer char-set:whitespace) "")
|
||||||
|
(if (string? user-agent)
|
||||||
|
(string-trim user-agent char-set:whitespace)
|
||||||
|
"")))
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,49 @@
|
||||||
|
;;;; Sending replies
|
||||||
|
;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;;; Reply codes
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;; (define http-reply/ok 200), etc.
|
||||||
|
;;; Also, build an alist HTTP-REPLY-TEXT-TABLE mapping integer reply codes
|
||||||
|
;;; to their diagnostic text messages.
|
||||||
|
|
||||||
|
(define-syntax define-http-reply-codes
|
||||||
|
(syntax-rules ()
|
||||||
|
((define-http-reply-codes table set (name val msg) ...)
|
||||||
|
(begin (define table '((val . msg) ...))
|
||||||
|
(define-enum-constant set name val)
|
||||||
|
...))))
|
||||||
|
|
||||||
|
(define-http-reply-codes http-reply-text-table http-reply
|
||||||
|
(ok 200 "OK")
|
||||||
|
(created 201 "Created")
|
||||||
|
(accepted 202 "Accepted")
|
||||||
|
(prov-info 203 "Provisional Information")
|
||||||
|
(no-content 204 "No Content")
|
||||||
|
|
||||||
|
(mult-choice 300 "Multiple Choices")
|
||||||
|
(moved-perm 301 "Moved Permanently")
|
||||||
|
(moved-temp 302 "Moved Temporarily")
|
||||||
|
(method 303 "Method (obsolete)")
|
||||||
|
(not-mod 304 "Not Modified")
|
||||||
|
|
||||||
|
(bad-request 400 "Bad Request")
|
||||||
|
(unauthorized 401 "Unauthorized")
|
||||||
|
(payment-req 402 "Payment Required")
|
||||||
|
(forbidden 403 "Forbidden")
|
||||||
|
(not-found 404 "Not Found")
|
||||||
|
(method-not-allowed 405 "Method Not Allowed")
|
||||||
|
(none-acceptable 406 "None Acceptable")
|
||||||
|
(proxy-auth-required 407 "Proxy Authentication Required")
|
||||||
|
(timeout 408 "Request Timeout")
|
||||||
|
(conflict 409 "Conflict")
|
||||||
|
(gone 410 "Gone")
|
||||||
|
|
||||||
|
(internal-error 500 "Internal Server Error")
|
||||||
|
(not-implemented 501 "Not Implemented")
|
||||||
|
(bad-gateway 502 "Bad Gateway")
|
||||||
|
(service-unavailable 503 "Service Unavailable")
|
||||||
|
(gateway-timeout 504 "Gateway Timeout"))
|
||||||
|
|
||||||
|
(define (reply-code->text code)
|
||||||
|
(cdr (assv code http-reply-text-table)))
|
|
@ -0,0 +1,40 @@
|
||||||
|
;;;; HTTP request
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;;; This code defines the http REQUEST data structure
|
||||||
|
|
||||||
|
(define-record request
|
||||||
|
method ; A string such as "GET", "PUT", etc.
|
||||||
|
uri ; The escaped URI string as read from request line.
|
||||||
|
url ; An http URL record (see url.scm).
|
||||||
|
version ; A (major . minor) integer pair.
|
||||||
|
headers ; An rfc822 header alist (see rfc822.scm).
|
||||||
|
socket) ; The socket connected to the client.
|
||||||
|
|
||||||
|
(define-record-discloser type/request
|
||||||
|
(lambda (req)
|
||||||
|
(list 'request
|
||||||
|
(request:method req)
|
||||||
|
(request:uri req)
|
||||||
|
(request:url req)
|
||||||
|
(request:version req)
|
||||||
|
(request:headers req)
|
||||||
|
(request:socket req))))
|
||||||
|
;;; A http protocol version is an integer pair: (major . minor).
|
||||||
|
|
||||||
|
(define (version< v1 v2)
|
||||||
|
(or (< (car v1) (car v2))
|
||||||
|
(and (= (car v1) (car v2))
|
||||||
|
(< (cdr v1) (cdr v2)))))
|
||||||
|
|
||||||
|
(define (version<= v1 v2) (not (version< v2 v1)))
|
||||||
|
|
||||||
|
(define (v0.9-request? req)
|
||||||
|
(version<= (request:version req) '(0 . 9)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (version->string v)
|
||||||
|
(string-append "HTTP/"
|
||||||
|
(number->string (car v))
|
||||||
|
"."
|
||||||
|
(number->string (cdr v))))
|
||||||
|
|
|
@ -0,0 +1,20 @@
|
||||||
|
;;; Text generation utilities.
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define (time->http-date-string time)
|
||||||
|
(format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
||||||
|
|
||||||
|
;;; Output the first chunk of a reply header.
|
||||||
|
|
||||||
|
(define (begin-http-header out reply-code)
|
||||||
|
(format out "~A ~d ~A\r~%"
|
||||||
|
server/protocol reply-code (reply-code->text reply-code))
|
||||||
|
(format out "Date: ~A\r~%" (time->http-date-string (time)))
|
||||||
|
(format out "Server: ~A\r~%" server/version))
|
||||||
|
|
||||||
|
(define (title-html out message new-protocol?)
|
||||||
|
(if new-protocol? (write-crlf out)) ; Separate html from headers.
|
||||||
|
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
|
||||||
|
(format out "<BODY>~%<H1>~A</H1>~%" message))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue