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

* 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:
interp 2002-05-26 17:56:56 +00:00
parent a4eec0ffb8
commit 77ebc6aea4
7 changed files with 399 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

240
modules.scm
View File

@ -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

4
scheme/httpd/constants.scm Normal file
View File

@ -0,0 +1,4 @@
;;; Constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define server/version "Scheme-Underground/1.0")
(define server/protocol "HTTP/1.0")

249
scheme/httpd/core.scm
View File

@ -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 "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
(format out "<BODY>~%<H1>~A</H1>~%" 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.

132
scheme/httpd/logging.scm Normal file
View File

@ -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)
"")))

49
scheme/httpd/reply-codes.scm Normal file
View File

@ -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)))

40
scheme/httpd/request.scm Normal file
View File

@ -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))))

20
scheme/httpd/text-generation.scm Normal file
View File

@ -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))