diff --git a/modules.scm b/modules.scm
index ac1ba66..f71a4b1 100644
--- a/modules.scm
+++ b/modules.scm
@@ -513,91 +513,32 @@
;;; httpd-core
(define-interface httpd-core-interface
- (export server/version
- 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
+ (export httpd
send-http-error-reply))
(define-structure httpd-core httpd-core-interface
- (open threads locks
- thread-fluids ; fork-thread
+ (open thread-fluids ; fork-thread
scsh
- receiving
- crlf-io
- rfc822
- char-set-lib
- defrec-package
- define-record-types
- handle
- conditions ; condition-stuff
- defenum-package
- httpd-error
- handle-fatal-error
+ receiving ; receive
+ crlf-io ; write-crlf, read-crlf-line
+ rfc822 ; read-rfc822-headers
+ char-set-lib ; char-set-complement, char-set:whitespace
+ handle ; ignore-errors
+ conditions ; condition-stuff
uri
url
- formats
- format-net
- sunet-utilities
+ formats ; format
+ format-net ; format-internet-host-address
+ rate-limit ; rate-limiting stuff
+ string-lib ; STRING-INDEX
+
+ handle-fatal-error
httpd-read-options
- rate-limit
- string-lib ; STRING-JOIN
- i/o ; make-null-output-port
+ httpd-error
+ httpd-logging
+ httpd-request
+ httpd-reply-codes
+ httpd-text-generation
scheme)
(files (httpd core)))
@@ -644,7 +585,8 @@
(define-structure httpd-access-control httpd-access-control-interface
(open big-scheme
- httpd-core
+ httpd-reply-codes
+ httpd-request
httpd-error
string-lib ; STRING-MAP
scsh
@@ -674,6 +616,119 @@
(open scheme conditions handle)
(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
@@ -698,9 +753,10 @@
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
(open scsh ; syscalls
formats ; FORMAT
- httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
- ; v0.9-request, begin-http-header
- httpd-error
+ httpd-request ; REQUEST record type, v0.9-request
+ httpd-reply-codes ; reply codes
+ httpd-text-generation ; begin-http-header
+ httpd-error ; HTTP-ERROR
htmlout
conditions ; CONDITION-STUFF
url ; HTTP-URL record type
@@ -718,8 +774,10 @@
(define-structure seval-handler seval-handler-interface
(open scsh ; syscalls & INDEX
httpd-error
- httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
- ; v0.9-request, reply formatting stuff.
+ httpd-request ; v0.9-request
+ httpd-reply-codes
+ httpd-text-generation ; begin-http-header
+ httpd-logging ; http-log
uri ; UNESCAPE-URI
htmlout ; Formatted HTML output
error-package ; ERROR
@@ -747,7 +805,9 @@
string-lib
conditions signals handle
htmlout
- httpd-core
+ httpd-request
+ httpd-text-generation
+ httpd-reply-codes
httpd-error
url
uri
@@ -770,7 +830,9 @@
nroff-n-decode))
(define-structure rman-gateway rman-gateway-interface
- (open httpd-core
+ (open httpd-reply-codes
+ httpd-request
+ httpd-text-generation
httpd-error
conditions
url
@@ -798,8 +860,10 @@
crlf-io ; WRITE-CRLF
uri
url ; HTTP-URL record type
- httpd-core ; REQUEST record type, HTTP-ERROR & reply codes
- ; version stuff
+ httpd-constants
+ httpd-logging
+ httpd-request
+ httpd-reply-codes
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
httpd-error ; HTTP-ERROR
scsh-utilities ; INDEX
diff --git a/scheme/httpd/constants.scm b/scheme/httpd/constants.scm
new file mode 100644
index 0000000..5053f20
--- /dev/null
+++ b/scheme/httpd/constants.scm
@@ -0,0 +1,4 @@
+;;; Constants
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define server/version "Scheme-Underground/1.0")
+(define server/protocol "HTTP/1.0")
diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
index 8387951..b56181b 100644
--- a/scheme/httpd/core.scm
+++ b/scheme/httpd/core.scm
@@ -23,150 +23,13 @@
;;; scsh system calls
;;; rfc822 header parsing
;;; crlf-io (read cr/lf terminated lines)
-;;; when, unless, switch, ? (conditionals)
;;; uri, url packages
-;;; defrec package (record structures)
-;;; defenum (enumerated types)
;;; ignore-errors (HANDLE package)
-;;; string hacking stuff
;;; char-set stuff
;;; format (Formatted output)
;;; httpd error stuff
;;; 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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The server top-level. PATH-HANDLER is the top-level request path handler --
@@ -301,45 +164,8 @@
;;;; HTTP request parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; This code defines the http REQUEST data structure, and provides
-;;;; code to read requests from an input 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))))
-
+;;;; This code provides procedures to read requests from an input
+;;;; port.
;;; Read and parse an http request from INPORT.
;;;
@@ -443,77 +269,6 @@
(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 "~%~%~A~%~%~%~%" message)
- (format out "~%~A
~%" message))
-
-
;;; (send-http-error-reply reply-code req options [message . extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Take an http-error condition, and format it into a reply to the client.
diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm
new file mode 100644
index 0000000..232915c
--- /dev/null
+++ b/scheme/httpd/logging.scm
@@ -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)
+ "")))
+
+
diff --git a/scheme/httpd/reply-codes.scm b/scheme/httpd/reply-codes.scm
new file mode 100644
index 0000000..4e8239e
--- /dev/null
+++ b/scheme/httpd/reply-codes.scm
@@ -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)))
diff --git a/scheme/httpd/request.scm b/scheme/httpd/request.scm
new file mode 100644
index 0000000..cc6f33e
--- /dev/null
+++ b/scheme/httpd/request.scm
@@ -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))))
+
diff --git a/scheme/httpd/text-generation.scm b/scheme/httpd/text-generation.scm
new file mode 100644
index 0000000..1339d00
--- /dev/null
+++ b/scheme/httpd/text-generation.scm
@@ -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 "~%~%~A~%~%~%~%" message)
+ (format out "~%~A
~%" message))
+
+