Rework the API of path handlers:
Path handlers must now return a response object similar to the response objects of the PLT web server, encapsulating headers, mime type, status code, and so on. A response object in turn can contain an encoding of a body. The only presently supported body type is a procedure which just prints the body. Other changes: - split file-dir-handler.scm out from handlers.scm - moved the ICON-NAME constructor parameters for file handlers to the options - removed input/output port redirections and work with paths explicitly
This commit is contained in:
sperber
parent
d6f81777c8
commit
d1438eb4a8
|
|
@ -74,12 +74,8 @@
|
|||
(set-port-buffering (socket:outport sock) bufpol/none) ; No buffering
|
||||
(fork-thread
|
||||
(lambda ()
|
||||
(with-current-input-port
|
||||
(socket:inport sock)
|
||||
(with-current-output-port
|
||||
(socket:outport sock)
|
||||
(set-port-buffering (current-input-port) bufpol/none)
|
||||
(process-toplevel-request sock host-address options)))
|
||||
(set-port-buffering (current-input-port) bufpol/none)
|
||||
(process-toplevel-request sock host-address options)
|
||||
(if *http-syslog?*
|
||||
(http-syslog (syslog-level debug) "<~a>~a [closing]~%"
|
||||
(pid)
|
||||
|
|
@ -120,43 +116,58 @@
|
|||
;; PROCESS-TOPLEVEL-REQUEST.
|
||||
;;
|
||||
;; We *oughta* map non-http-errors into replies anyway.
|
||||
(with-fatal-error-handler (lambda (c decline) ; No call to decline
|
||||
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address)
|
||||
c)
|
||||
(if (http-error? c) ; -- we handle all.
|
||||
(apply (lambda (reply-code req . args)
|
||||
(apply send-http-error-reply
|
||||
reply-code req options
|
||||
args))
|
||||
(condition-stuff c))
|
||||
(with-fatal-error-handler
|
||||
(lambda (c decline)
|
||||
(http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address)
|
||||
c))
|
||||
(shutdown-socket sock shutdown/sends+receives)
|
||||
(http-syslog (syslog-level info) "<~a>~a [shut down]~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address)))))
|
||||
|
||||
(let ((req (with-fatal-error-handler ; Map syntax errors
|
||||
(lambda (c decline) ; to http errors.
|
||||
(if (fatal-syntax-error? c)
|
||||
(apply http-error http-reply/bad-request
|
||||
#f ; No request yet.
|
||||
"Request parsing error -- report to client maintainer."
|
||||
(condition-stuff c))
|
||||
(decline))) ; Actual work:
|
||||
(parse-http-request sock options))) ; (1) Parse request.
|
||||
(handler
|
||||
(httpd-options-path-handler options)))
|
||||
(handler (http-url:path (request:url req)) req) ; (2) Deal with it.
|
||||
(http-log req http-reply/ok))))
|
||||
|
||||
|
||||
(with-fatal-error-handler*
|
||||
(lambda (c decline)
|
||||
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address)
|
||||
c)
|
||||
(with-fatal-error-handler*
|
||||
(lambda (c decline)
|
||||
(http-syslog (syslog-level notice) "<~a>~a [error shutting down: ~s]~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address)
|
||||
c))
|
||||
(lambda ()
|
||||
(shutdown-socket sock shutdown/sends+receives)
|
||||
(http-syslog (syslog-level info) "<~a>~a [shut down]~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address))
|
||||
(decline))))
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(with-fatal-error-handler*
|
||||
(lambda (c decline)
|
||||
(http-syslog (syslog-level notice) "<~a>~a: error: ~s~%"
|
||||
(pid)
|
||||
(format-internet-host-address host-address)
|
||||
c)
|
||||
(cond
|
||||
((http-error? c)
|
||||
(apply (lambda (reply-code req . args)
|
||||
(values req
|
||||
(apply make-http-error-response
|
||||
reply-code req
|
||||
args)))
|
||||
(condition-stuff c)))
|
||||
((fatal-syntax-error? c)
|
||||
(values #f
|
||||
(apply make-http-error-response http-reply/bad-request
|
||||
#f ; No request yet.
|
||||
"Request parsing error -- report to client maintainer."
|
||||
(condition-stuff c))))
|
||||
(else
|
||||
(decline))))
|
||||
(lambda ()
|
||||
(let* ((req (parse-http-request sock options))
|
||||
(response ((httpd-options-path-handler options)
|
||||
(http-url:path (request:url req))
|
||||
req)))
|
||||
(values req response)))))
|
||||
(lambda (req response)
|
||||
(send-http-response response (socket:outport sock) options)
|
||||
(http-log req http-reply/ok))))))
|
||||
|
||||
;;;; HTTP request parsing
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -172,8 +183,7 @@
|
|||
;;; the Web, the protocols are redundant, underconstrained, and ill-specified.
|
||||
|
||||
(define (parse-http-request sock options)
|
||||
(let ((line (read-crlf-line)))
|
||||
; (display line (current-error-port)) (newline (current-error-port))
|
||||
(let ((line (read-crlf-line (socket:inport sock))))
|
||||
;; Blat out some logging info.
|
||||
(if *http-syslog?*
|
||||
(call-with-values
|
||||
|
|
@ -198,7 +208,7 @@
|
|||
(uri-string (cadr elts))
|
||||
(url (parse-http-servers-url-fragment uri-string sock options))
|
||||
(headers (if (equal? version '(0 . 9)) '()
|
||||
(read-rfc822-headers))))
|
||||
(read-rfc822-headers (socket:inport sock)))))
|
||||
(make-request meth uri-string url version headers sock))))))
|
||||
|
||||
|
||||
|
|
@ -264,146 +274,167 @@
|
|||
(else (list (substring s start (string-length s)))))))
|
||||
(else '()))))
|
||||
|
||||
(define (send-http-response response port options)
|
||||
|
||||
;;; (send-http-error-reply reply-code req options [message . extras])
|
||||
(display server/protocol port)
|
||||
(write-char #\space port)
|
||||
(display (response-code response) port)
|
||||
(write-char #\space port)
|
||||
(display (response-message response) port)
|
||||
(write-crlf port)
|
||||
|
||||
(send-http-headers
|
||||
(list (cons 'server server/version)
|
||||
(cons 'content-type (response-mime response))
|
||||
(cons 'date (time->http-date-string (response-seconds response))))
|
||||
port)
|
||||
(send-http-headers (response-extras response) port)
|
||||
|
||||
(write-crlf port)
|
||||
|
||||
(display-http-body (response-body response) port options))
|
||||
|
||||
(define (send-http-headers headers port)
|
||||
(for-each (lambda (pair)
|
||||
(display (car pair) port)
|
||||
(display ": " port)
|
||||
(display (cdr pair) port)
|
||||
(write-crlf port))
|
||||
headers))
|
||||
|
||||
;;; (make-http-error-response reply-code req [message . extras])
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Take an http-error condition, and format it into a reply to the client.
|
||||
;;;
|
||||
;;; As a special case, request REQ is allowed to be #f, meaning we haven't
|
||||
;;; even had a chance to parse and construct the request. This is only used
|
||||
;;; for 400 BAD-REQUEST error report, and we make minimal assumptions in this
|
||||
;;; case (0.9 protocol for the reply, for example). I might be better off
|
||||
;;; writing a special-case procedure for that case...
|
||||
;;; for 400 BAD-REQUEST error report.
|
||||
|
||||
;;; SEND-HTTP-ERROR-REPLY is called from error handlers, so to avoid
|
||||
;;; MAKE-HTTP-ERROR-RESPONSE is called from error handlers, so to avoid
|
||||
;;; infinite looping, if an error occurs while it is running, we just
|
||||
;;; silently return. (We no longer need to do this; I have changed
|
||||
;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll
|
||||
;;; leave it in to play it safe.)
|
||||
|
||||
(define (send-http-error-reply reply-code req options . args)
|
||||
(ignore-errors (lambda () ; Ignore errors -- see note above.
|
||||
(apply really-send-http-error-reply reply-code req options args))))
|
||||
(define (make-http-error-response reply-code req . args)
|
||||
(ignore-errors
|
||||
(lambda () ; Ignore errors -- see note above.
|
||||
(apply really-make-http-error-response reply-code req args))))
|
||||
|
||||
(define (really-send-http-error-reply reply-code req options . args)
|
||||
(define (really-make-http-error-response reply-code req . args)
|
||||
(http-log req reply-code)
|
||||
|
||||
(let* ((message (if (pair? args) (car args)))
|
||||
(let* ((message (and (pair? args) (car args)))
|
||||
(extras (if (pair? args) (cdr args) '()))
|
||||
|
||||
(new-protocol? (and req (not (v0.9-request? req)))) ; 1.0 or better?
|
||||
(generic-title (lambda (port)
|
||||
(title-html port
|
||||
(reply-code->text reply-code))))
|
||||
(close-html (lambda (port)
|
||||
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
|
||||
(write-string "</BODY>\n" port)))
|
||||
|
||||
(create-response
|
||||
(lambda (headers writer-proc)
|
||||
(make-response reply-code
|
||||
(reply-code->text reply-code)
|
||||
(time)
|
||||
"text/html"
|
||||
headers
|
||||
(make-writer-body writer-proc)))))
|
||||
|
||||
;; Is it OK to send back an HTML body explaining things?
|
||||
(html-ok? (or (not req)
|
||||
(not (string=? (request:method req) "HEAD"))))
|
||||
|
||||
(out (current-output-port))
|
||||
|
||||
(generic-title (lambda ()
|
||||
(title-html out
|
||||
(reply-code->text reply-code)
|
||||
new-protocol?)))
|
||||
|
||||
(do-msg (lambda () (cond (message (display message out) (newline out))))))
|
||||
|
||||
(if new-protocol? (begin-http-header out reply-code))
|
||||
|
||||
;; Don't output the blank line, as individual clauses might
|
||||
;; want to add more headers.
|
||||
(if html-ok? (write-string "Content-type: text/html\r\n" out))
|
||||
|
||||
;; If html-ok?, we must send back some html, with the <body> tag unclosed.
|
||||
(cond
|
||||
;; This error reply requires two args: message is the new URI: field,
|
||||
;; and the first EXTRA is the older Location: field.
|
||||
((or (= reply-code http-reply/moved-temp)
|
||||
(= reply-code http-reply/moved-perm))
|
||||
(create-response
|
||||
(list (cons 'uri message)
|
||||
(cons 'location (car extras)))
|
||||
(lambda (port options)
|
||||
(title-html port "Document moved")
|
||||
(format port
|
||||
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
|
||||
(if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
|
||||
message)
|
||||
(close-html port))))
|
||||
|
||||
;; This error reply requires two args: message is the new URI: field,
|
||||
;; and the first EXTRA is the older Location: field.
|
||||
((or (= reply-code http-reply/moved-temp)
|
||||
(= reply-code http-reply/moved-perm))
|
||||
(if new-protocol?
|
||||
(begin
|
||||
(format out "URI: ~A\r~%" message)
|
||||
(format out "Location: ~A\r~%" (car extras))))
|
||||
(if html-ok?
|
||||
(begin
|
||||
(title-html out "Document moved" new-protocol?)
|
||||
(format out
|
||||
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
|
||||
(if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
|
||||
message))))
|
||||
((= reply-code http-reply/bad-request)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(write-string "<P>Client sent a query that this server could not understand.\n"
|
||||
port)
|
||||
(if message (format port "<BR>~%Reason: ~A~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/bad-request)
|
||||
(if html-ok?
|
||||
(begin
|
||||
(generic-title)
|
||||
(write-string "<P>Client sent a query that this server could not understand.\n"
|
||||
out)
|
||||
(if message (format out "<BR>~%Reason: ~A~%" message)))))
|
||||
((= reply-code http-reply/unauthorized)
|
||||
(create-response
|
||||
(list (cons 'WWW-Authenticate message)) ; Vas is das?
|
||||
(lambda (port options)
|
||||
(title-html port "Authorization Required")
|
||||
(write-string "<P>Browser not authentication-capable or\n" port)
|
||||
(write-string "authentication failed.\n" port)
|
||||
(if message (format port "~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/unauthorized)
|
||||
(if new-protocol?
|
||||
(format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
|
||||
(if html-ok?
|
||||
(begin
|
||||
(title-html out "Authorization Required" new-protocol?)
|
||||
(write-string "<P>Browser not authentication-capable or\n" out)
|
||||
(write-string "authentication failed.\n" out)
|
||||
(if message (format out "~a~%" message)))))
|
||||
|
||||
((= reply-code http-reply/forbidden)
|
||||
(if (not html-ok?)
|
||||
(begin
|
||||
(title-html out "Request not allowed." new-protocol?)
|
||||
(format out
|
||||
"Your client does not have permission to perform a ~A~%"
|
||||
(request:method req))
|
||||
(format out "operation on url ~a.~%" (request:uri req))
|
||||
(if message (format out "<P>~%~a~%" message)))))
|
||||
((= reply-code http-reply/forbidden)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(title-html port "Request not allowed.")
|
||||
(format port
|
||||
"Your client does not have permission to perform a ~A~%"
|
||||
(request:method req))
|
||||
(format port "operation on url ~a.~%" (request:uri req))
|
||||
(if message (format port "<P>~%~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/not-found)
|
||||
(if html-ok?
|
||||
(begin
|
||||
(title-html out "URL not found" new-protocol?)
|
||||
(write-string
|
||||
"<P>The requested URL was not found on this server.\n"
|
||||
out)
|
||||
(if message (format out "<P>~%~a~%" message)))))
|
||||
((= reply-code http-reply/not-found)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(title-html port "URL not found")
|
||||
(write-string
|
||||
"<P>The requested URL was not found on this server.\n"
|
||||
port)
|
||||
(if message (format port "<P>~%~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/internal-error)
|
||||
(http-syslog (syslog-level error) "internal-error: ~A" message)
|
||||
(if html-ok?
|
||||
(begin
|
||||
(generic-title)
|
||||
(format out "The server encountered an internal error or
|
||||
((= reply-code http-reply/internal-error)
|
||||
(http-syslog (syslog-level error) "internal-error: ~A" message)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(format port "The server encountered an internal error or
|
||||
misconfiguration and was unable to complete your request.
|
||||
<P>
|
||||
Please inform the server administrator, ~A, of the circumstances leading to
|
||||
the error, and time it occured.~%"
|
||||
(httpd-options-server-admin options))
|
||||
(if message (format out "<P>~%~a~%" message)))))
|
||||
|
||||
((= reply-code http-reply/not-implemented)
|
||||
(if html-ok?
|
||||
(begin
|
||||
(generic-title)
|
||||
(format out "This server does not currently implement
|
||||
(httpd-options-server-admin options))
|
||||
(if message (format port "<P>~%~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
((= reply-code http-reply/not-implemented)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(format port "This server does not currently implement
|
||||
the requested method (~A).~%"
|
||||
(request:method req))
|
||||
(if message (format out "<P>~a~%" message)))))
|
||||
(request:method req))
|
||||
(if message (format port "<P>~a~%" message))
|
||||
(close-html port))))
|
||||
|
||||
(else
|
||||
(http-syslog (syslog-level info) "Skipping unhandled reply code ~A.~%" reply-code)
|
||||
(if html-ok? (generic-title))))
|
||||
|
||||
(cond
|
||||
(html-ok?
|
||||
;; Output extra stuff and close the <body> tag.
|
||||
(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
|
||||
(write-string "</BODY>\n" out)))
|
||||
; (force-output out) ;;; TODO check this
|
||||
; (flush-all-ports)
|
||||
(force-output out)
|
||||
; (if bkp? (breakpoint "http error"))
|
||||
))
|
||||
(else
|
||||
(http-syslog (syslog-level info) "Skipping unhandled reply code ~A.~%" reply-code)
|
||||
(create-response
|
||||
'()
|
||||
(lambda (port options)
|
||||
(generic-title port)
|
||||
(close-html port)))))))
|
||||
|
||||
|
||||
;;; Return my Internet host name (my fully-qualified domain name).
|
||||
|
|
|
|||
|
|
@ -0,0 +1,500 @@
|
|||
(define server/buffer-size 8192) ; WTF
|
||||
|
||||
;;; (home-dir-handler user-public-dir) -> handler
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Return a path handler that looks things up in a specific directory
|
||||
;;; in the user's home directory. If ph = (home-dir-handler "public_html")
|
||||
;;; then ph is a path-handler that serves files out of peoples' public_html
|
||||
;;; subdirectory. So
|
||||
;;; (ph '("shivers" "hk.html") req)
|
||||
;;; will serve the file
|
||||
;;; ~shivers/public_html/hk.html
|
||||
;;; The path handler treats the URL path as (<user> . <file-path>),
|
||||
;;; serving
|
||||
;;; ~<user>/<user-public-dir>/<file-path>
|
||||
|
||||
(define (home-dir-handler user-public-dir)
|
||||
(lambda (path req)
|
||||
(if (pair? path)
|
||||
(make-rooted-file-path-response (string-append (http-homedir (car path) req)
|
||||
"/"
|
||||
user-public-dir)
|
||||
(cdr path)
|
||||
file-serve-response
|
||||
req)
|
||||
(make-http-error-response http-reply/bad-request
|
||||
req
|
||||
"Path contains no home directory."))))
|
||||
|
||||
;;; (tilde-home-dir-handler-predicate path)
|
||||
;;; (tilde-home-dir-handler user-public-dir)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
|
||||
;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
|
||||
;;; default handler.
|
||||
|
||||
(define (tilde-home-dir-handler-predicate path)
|
||||
(lambda (path)
|
||||
(and (pair? path) ; Is it a ~foo/...
|
||||
(let ((head (car path))) ; home-directory path?
|
||||
(and (> (string-length head) 0)
|
||||
(char=? (string-ref head 0) #\~))))))
|
||||
|
||||
(define (tilde-home-dir-handler user-public-dir)
|
||||
(lambda (path req)
|
||||
(let* ((tilde-home (car path)) ; Yes.
|
||||
(slen (string-length tilde-home))
|
||||
(subdir (string-append
|
||||
(http-homedir (substring tilde-home 1 slen) req)
|
||||
"/"
|
||||
user-public-dir)))
|
||||
(make-rooted-file-path-response subdir (cdr path) file-serve-response req))))
|
||||
|
||||
|
||||
;;; Make a handler that serves files relative to a particular root
|
||||
;;; in the file system. You may follow symlinks, but you can't back up
|
||||
;;; past ROOT with ..'s.
|
||||
|
||||
(define (rooted-file-handler root)
|
||||
(lambda (path req)
|
||||
(make-rooted-file-path-response root path file-serve-response req)))
|
||||
|
||||
;;; Dito, but also serve directory indices for directories without
|
||||
;;; index.html.
|
||||
|
||||
(define (rooted-file-or-directory-handler root)
|
||||
(lambda (path req)
|
||||
(make-rooted-file-path-response root path
|
||||
file-serve-and-dir-response
|
||||
req)))
|
||||
|
||||
|
||||
;;; The null path handler -- handles nothing, sends back an error reply.
|
||||
;;; Can be useful as the default in table-driven path handlers.
|
||||
|
||||
(define (null-path-handler path req)
|
||||
(make-http-error-response http-reply/not-found req))
|
||||
|
||||
;;;; Support procs for the path handlers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; (MAKE-ROOTED-FILE-PATH-RESPONSE root file-path req)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Do a request for a file. The file-name is determined by appending the
|
||||
;;; the FILE-PATH list the string ROOT. E.g., if
|
||||
;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html")
|
||||
;;; then we serve file
|
||||
;;; /usr/shivers/a/b/c/foo.html
|
||||
;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
|
||||
;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path
|
||||
;;; sequences are processed away by the browser when the URI is converted
|
||||
;;; to an absolute URI before it is sent off to the server.)
|
||||
;;; It is possible to sneak a .. past this kind of front-end resolving by
|
||||
;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
|
||||
;;; this, MAKE-ROOTED-FILE-PATH-RESPONSE will catch it, and abort the transaction.
|
||||
;;; So you cannot make the reference back up past ROOT. E.g., this is
|
||||
;;; not allowed:
|
||||
;;; FILE-PATH = ("a" "../.." "c" "foo.html")
|
||||
;;;
|
||||
;;; Only GET and HEAD ops are provided.
|
||||
;;; The URL's <search> component must be #f.
|
||||
;;; The file is served if the server has read or stat(2) access to it,
|
||||
;;; respectively. If the server is run as root, this might be a problem.
|
||||
;;;
|
||||
;;; FILE-SERVE is a procedure which gets passed the file name, the
|
||||
;;; path, and the HTTP request to serve the file propert after the
|
||||
;;; security checks. Look in ROOTED-FILE-HANDLER and
|
||||
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
|
||||
|
||||
(define (make-rooted-file-path-response root file-path file-serve-response req)
|
||||
(if (http-url:search (request:url req))
|
||||
(make-http-error-response http-reply/bad-request req
|
||||
"Indexed search not provided for this URL.")
|
||||
(cond ((dotdot-check root file-path) =>
|
||||
(lambda (fname)
|
||||
(file-serve-response fname file-path req)))
|
||||
(else
|
||||
(make-http-error-response http-reply/bad-request req
|
||||
"URL contains unresolvable ..'s.")))))
|
||||
|
||||
|
||||
;; Just (file-info fname) with error handling.
|
||||
|
||||
(define (stat-carefully fname req)
|
||||
(with-errno-handler
|
||||
((errno packet)
|
||||
((errno/noent)
|
||||
(http-error http-reply/not-found req))
|
||||
((errno/acces)
|
||||
(http-error http-reply/forbidden req)))
|
||||
(file-info fname #t)))
|
||||
|
||||
;;; A basic file request handler -- ship the dude the file. No fancy path
|
||||
;;; checking. That has presumably been taken care of. This handler only
|
||||
;;; takes care of GET and HEAD methods.
|
||||
|
||||
(define (file-serve-or-dir-response fname file-path req directory-serve-response)
|
||||
(if (file-name-directory? fname) ; Simple index generation.
|
||||
(directory-serve-response fname file-path req)
|
||||
|
||||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((or (string=? request-method "GET")
|
||||
(string=? request-method "HEAD")) ; Absolutely.
|
||||
(let ((info (stat-carefully fname req)))
|
||||
(case (file-info:type info)
|
||||
|
||||
((regular fifo socket)
|
||||
(send-file-response fname info req))
|
||||
|
||||
((directory) ; Send back a redirection "foo" -> "foo/"
|
||||
(make-http-error-response
|
||||
http-reply/moved-perm req
|
||||
(string-append (request:uri req) "/")
|
||||
(string-append (http-url->string (request:url req))
|
||||
"/")))
|
||||
|
||||
(else (make-http-error-response http-reply/forbidden req)))))
|
||||
|
||||
(else (make-http-error-response http-reply/method-not-allowed req))))))
|
||||
|
||||
(define (directory-index-serve-response fname file-path req)
|
||||
(file-serve-response (string-append fname "index.html") file-path req))
|
||||
|
||||
(define (file-serve-response fname file-path req)
|
||||
(file-serve-or-dir-response fname file-path req
|
||||
directory-index-serve-response))
|
||||
|
||||
(define (tag->alt tag)
|
||||
(case tag
|
||||
((directory) "[DIR]")
|
||||
((text) "[TXT]")
|
||||
((doc) "[DOC]")
|
||||
((image) "[IMG]")
|
||||
((movie) "[MVI]")
|
||||
((audio) "[AU ]")
|
||||
((archive) "[TAR]")
|
||||
((compressed) "[ZIP]")
|
||||
((uu) "[UU ]")
|
||||
((binhex) "[HQX]")
|
||||
((binary) "[BIN]")
|
||||
(else "[ ]")))
|
||||
|
||||
;; These icons can, for example, be found in the cern-httpd-3.0
|
||||
;; distribution at http://www.w3.org/pub/WWW/Daemon/
|
||||
|
||||
(define (tag->icon tag)
|
||||
(case tag
|
||||
((directory) "directory.xbm")
|
||||
((text) "text.xbm")
|
||||
((doc) "doc.xbm")
|
||||
((image) "image.xbm")
|
||||
((movie) "movie.xbm")
|
||||
((audio) "sound.xbm")
|
||||
((archive) "tar.xbm")
|
||||
((compressed) "compressed.xbm")
|
||||
((uu) "uu.xbm")
|
||||
((binhex) "binhex.xbm")
|
||||
((binary) "binary.xbm")
|
||||
((blank) "blank.xbm")
|
||||
((back) "back.xbm")
|
||||
(else "unknown.xbm")))
|
||||
|
||||
(define (file-extension->tag fname)
|
||||
(let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".txt") 'text)
|
||||
((or (string-ci=? ext ".doc")
|
||||
(string-ci=? ext ".html")
|
||||
(string-ci=? ext ".rtf")
|
||||
(string-ci=? ext ".tex")) 'doc)
|
||||
((or (string-ci=? ext ".gif")
|
||||
(string-ci=? ext ".jpg")
|
||||
(string-ci=? ext ".jpeg")
|
||||
(string-ci=? ext ".tiff")
|
||||
(string-ci=? ext ".tif")) 'image)
|
||||
((or (string-ci=? ext ".mpeg")
|
||||
(string-ci=? ext ".mpg")) 'movie)
|
||||
((or (string-ci=? ext ".au")
|
||||
(string-ci=? ext ".snd")
|
||||
(string-ci=? ext ".wav")) 'audio)
|
||||
((or (string-ci=? ext ".tar")
|
||||
(string-ci=? ext ".zip")
|
||||
(string-ci=? ext ".zoo")) 'archive)
|
||||
((or (string-ci=? ext ".gz")
|
||||
(string-ci=? ext ".Z")
|
||||
(string-ci=? ext ".z")) 'compressed)
|
||||
((string-ci=? ext ".uu") 'uu)
|
||||
((string-ci=? ext ".hqx") 'binhex)
|
||||
(else 'binary))))
|
||||
|
||||
(define (file-tag fname type)
|
||||
(case type
|
||||
((regular fifo socket) (file-extension->tag fname))
|
||||
((directory) 'directory)
|
||||
(else 'unknown)))
|
||||
|
||||
(define (time->directory-index-date-string time)
|
||||
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
||||
|
||||
(define (read-max-lines fname max)
|
||||
(call-with-input-file
|
||||
fname
|
||||
(lambda (port)
|
||||
(let loop ((r "") (i max))
|
||||
(if (zero? i)
|
||||
r
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
r
|
||||
(loop (string-append r " " line) (- i 1)))))))))
|
||||
|
||||
(define (string-cut s n)
|
||||
(if (>= (string-length s) n)
|
||||
(substring s 0 n)
|
||||
s))
|
||||
|
||||
(define html-file-header
|
||||
(let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
|
||||
(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
|
||||
(lambda (fname n)
|
||||
(let ((stuff (read-max-lines fname 10)))
|
||||
(cond
|
||||
((regexp-exec title-tag-regexp stuff)
|
||||
=> (lambda (open-match)
|
||||
(cond
|
||||
((regexp-exec title-close-tag-regexp stuff
|
||||
(match:end open-match 0))
|
||||
=> (lambda (close-match)
|
||||
(string-cut (substring stuff
|
||||
(match:end open-match 0)
|
||||
(match:start close-match 0))
|
||||
n)))
|
||||
(else (string-cut (substring stuff
|
||||
(match:end open-match 0)
|
||||
(string-length stuff))
|
||||
n)))))
|
||||
(else ""))))))
|
||||
|
||||
(define (file-documentation fname n)
|
||||
(cond
|
||||
((file-extension->content-type fname)
|
||||
=> (lambda (content-type)
|
||||
(if (and (string=? content-type "text/html" )
|
||||
(file-readable? fname))
|
||||
(html-file-header fname n)
|
||||
"")))
|
||||
(else "")))
|
||||
|
||||
(define (directory-index req dir icon-name port)
|
||||
|
||||
(define (pad-file-name file)
|
||||
(write-string (make-string (max (- 21 (string-length file))
|
||||
1)
|
||||
#\space)
|
||||
port))
|
||||
|
||||
(define (emit-file-name file)
|
||||
(let ((l (string-length file)))
|
||||
(if (<= l 20)
|
||||
(emit-text file port)
|
||||
(emit-text (substring file 0 20) port))))
|
||||
|
||||
(define (index-entry file)
|
||||
(let* ((fname (directory-as-file-name (string-append dir file)))
|
||||
(info (file-info fname #t))
|
||||
(type (file-info:type info))
|
||||
(size (file-info:size info))
|
||||
(tag (file-tag file type)))
|
||||
(emit-tag port 'img
|
||||
(cons 'src (icon-name tag))
|
||||
(cons 'alt (tag->alt tag)))
|
||||
(with-tag port a ((href file))
|
||||
(emit-file-name file))
|
||||
(pad-file-name file)
|
||||
(emit-text (time->directory-index-date-string (file-info:mtime info)) port)
|
||||
(if size
|
||||
(let* ((size-string
|
||||
(string-append (number->string (quotient size 1024))
|
||||
"K"))
|
||||
(size-string
|
||||
(if (<= (string-length size-string) 7)
|
||||
size-string
|
||||
(string-append (number->string (quotient size (* 1024 1024)))
|
||||
"M")))
|
||||
(size-string
|
||||
(if (<= (string-length size-string) 8)
|
||||
(string-append
|
||||
(make-string (- 8 (string-length size-string)) #\space)
|
||||
size-string)
|
||||
size-string)))
|
||||
(write-string size-string port))
|
||||
(write-string (make-string 8 #\space) port))
|
||||
(write-char #\space port)
|
||||
(emit-text (file-documentation fname 24) port)
|
||||
(write-crlf port)))
|
||||
|
||||
(let ((files (directory-files dir)))
|
||||
(for-each index-entry files)
|
||||
(length files)))
|
||||
|
||||
(define (directory-serve-response fname file-path req)
|
||||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((or (string=? request-method "GET")
|
||||
(string=? request-method "HEAD"))
|
||||
|
||||
(if (not (eq? 'directory
|
||||
(file-info:type (file-info fname #t))))
|
||||
(make-http-error-response http-reply/forbidden req)
|
||||
(make-response
|
||||
http-reply/ok
|
||||
(reply-code->text http-reply/ok)
|
||||
(time)
|
||||
"text/html"
|
||||
'()
|
||||
(make-writer-body
|
||||
(lambda (port options)
|
||||
(let* ((icon-option (httpd-options-icon-name options))
|
||||
(icon-name
|
||||
(cond
|
||||
((procedure? icon-option) icon-option)
|
||||
((string? icon-option)
|
||||
(lambda (tag)
|
||||
(string-append icon-option (tag->icon tag))))
|
||||
(else tag->icon))))
|
||||
(with-tag port html ()
|
||||
(let ((title (string-append "Index of /"
|
||||
(string-join file-path "/"))))
|
||||
(with-tag port head ()
|
||||
(emit-title port title))
|
||||
(with-tag port body ()
|
||||
(emit-header port 1 title)
|
||||
(with-tag port pre ()
|
||||
(emit-tag port 'img
|
||||
(cons 'src (icon-name 'blank))
|
||||
(cons 'alt " "))
|
||||
(write-string "Name " port)
|
||||
(write-string "Last modified " port)
|
||||
(write-string "Size " port)
|
||||
(write-string "Description" port)
|
||||
(emit-tag port 'hr)
|
||||
(emit-tag port 'img
|
||||
(cons 'src (icon-name 'back))
|
||||
(cons 'alt "[UP ]"))
|
||||
(if (not (null? file-path))
|
||||
(begin
|
||||
(with-tag port a ((href ".."))
|
||||
(write-string "Parent directory" port))
|
||||
(write-crlf port)))
|
||||
(let ((n-files (directory-index req fname icon-name port)))
|
||||
(emit-tag port 'hr)
|
||||
(format port "~d files" n-files))))))))))))
|
||||
(else
|
||||
(make-http-error-response http-reply/method-not-allowed req)))))
|
||||
|
||||
(define (index-or-directory-serve-response fname file-path req)
|
||||
(let ((index-fname (string-append fname "index.html")))
|
||||
(if (file-readable? index-fname)
|
||||
(file-serve-response index-fname file-path req)
|
||||
(directory-serve-response fname file-path req))))
|
||||
|
||||
(define (file-serve-and-dir-response fname file-path req)
|
||||
(file-serve-or-dir-response fname file-path req
|
||||
index-or-directory-serve-response))
|
||||
|
||||
;;; Look up user's home directory, generating an HTTP error reply if you lose.
|
||||
|
||||
(define (http-homedir username req)
|
||||
(with-fatal-error-handler (lambda (c decline)
|
||||
(apply http-error http-reply/bad-request req
|
||||
"Couldn't find user's home directory."
|
||||
(condition-stuff c)))
|
||||
|
||||
(home-dir username)))
|
||||
|
||||
|
||||
(define (send-file-response filename info req)
|
||||
(if (file-not-readable? filename) ; #### double stats are no good
|
||||
(make-http-error-response http-reply/not-found req)
|
||||
(receive (stripped-filename content-encoding)
|
||||
(file-extension->content-encoding filename)
|
||||
(make-response http-reply/ok
|
||||
(reply-code->text http-reply/ok)
|
||||
(time)
|
||||
(file-extension->content-type stripped-filename)
|
||||
(append (if content-encoding
|
||||
(cons 'content-encoding content-encoding)
|
||||
'())
|
||||
(list
|
||||
(cons 'last-modified
|
||||
(time->http-date-string
|
||||
(file-info:mtime info)))
|
||||
(cons 'content-length (file-info:size info))))
|
||||
(make-writer-body
|
||||
(lambda (port options)
|
||||
(call-with-input-file filename
|
||||
(lambda (in)
|
||||
(copy-inport->outport in port)))))))))
|
||||
|
||||
|
||||
;;; Assemble a filename from ROOT and the elts of PATH-LIST.
|
||||
;;; If the assembled filename contains a .. subdirectory, return #f,
|
||||
;;; otw return the filename.
|
||||
|
||||
(define dotdot-check
|
||||
(let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir.
|
||||
(lambda (root path-list)
|
||||
(let ((fname (if (null? path-list) root ; Bogus hack.
|
||||
(string-append (file-name-as-directory root)
|
||||
(string-join path-list "/")))))
|
||||
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
|
||||
fname)))))
|
||||
|
||||
(define (file-extension->content-type fname)
|
||||
(let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".html") "text/html")
|
||||
((string-ci=? ext ".txt") "text/plain")
|
||||
((string-ci=? ext ".gif") "image/gif")
|
||||
((string-ci=? ext ".png") "image/png")
|
||||
((or (string-ci=? ext ".jpg")
|
||||
(string-ci=? ext ".jpeg")) "image/jpeg")
|
||||
((or (string-ci=? ext ".tiff")
|
||||
(string-ci=? ext ".tif")) "image/tif")
|
||||
((string-ci=? ext ".rtf") "text/rtf")
|
||||
((or (string-ci=? ext ".mpeg")
|
||||
(string-ci=? ext ".mpg")) "video/mpeg")
|
||||
((or (string-ci=? ext ".au")
|
||||
(string-ci=? ext ".snd")) "audio/basic")
|
||||
((string-ci=? ext ".wav") "audio/x-wav")
|
||||
((string-ci=? ext ".dvi") "application/x-dvi")
|
||||
((or (string-ci=? ext ".tex")
|
||||
(string-ci=? ext ".latex")) "application/latex")
|
||||
((string-ci=? ext ".zip") "application/zip")
|
||||
((string-ci=? ext ".tar") "application/tar")
|
||||
((string-ci=? ext ".ps") "application/postscript")
|
||||
((string-ci=? ext ".pdf") "application/pdf")
|
||||
(else "application/octet-stream"))))
|
||||
|
||||
(define (file-extension->content-encoding fname)
|
||||
(cond
|
||||
((let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".Z") "x-compress")
|
||||
((string-ci=? ext ".gz") "x-gzip")
|
||||
(else #f)))
|
||||
=> (lambda (encoding)
|
||||
(values (file-name-sans-extension fname) encoding)))
|
||||
(else (values fname #f))))
|
||||
|
||||
;;; Timeout on network writes?
|
||||
|
||||
(define (copy-inport->outport in out)
|
||||
(let ((buf (make-string server/buffer-size)))
|
||||
(let loop ()
|
||||
(cond ((read-string! buf in) => (lambda (nchars)
|
||||
(write-string buf out 0 nchars)
|
||||
(loop))))))
|
||||
(force-output out))
|
||||
|
|
@ -33,9 +33,6 @@
|
|||
(handler (cdr path) req)
|
||||
(default-handler path req))))
|
||||
|
||||
(define server/buffer-size 8192) ; WTF
|
||||
|
||||
|
||||
;;; (alist-path-dispatcher handler-alist default-handler) -> handler
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; This function creates a table-driven path-handler that dispatches off
|
||||
|
|
@ -57,512 +54,3 @@
|
|||
default-handler))
|
||||
default-handler
|
||||
handler-alist))
|
||||
|
||||
;;; (home-dir-handler user-public-dir) -> handler
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Return a path handler that looks things up in a specific directory
|
||||
;;; in the user's home directory. If ph = (home-dir-handler "public_html")
|
||||
;;; then ph is a path-handler that serves files out of peoples' public_html
|
||||
;;; subdirectory. So
|
||||
;;; (ph '("shivers" "hk.html") req)
|
||||
;;; will serve the file
|
||||
;;; ~shivers/public_html/hk.html
|
||||
;;; The path handler treats the URL path as (<user> . <file-path>),
|
||||
;;; serving
|
||||
;;; ~<user>/<user-public-dir>/<file-path>
|
||||
|
||||
(define (home-dir-handler user-public-dir)
|
||||
(lambda (path req)
|
||||
(if (pair? path)
|
||||
(serve-rooted-file-path (string-append (http-homedir (car path) req)
|
||||
"/"
|
||||
user-public-dir)
|
||||
(cdr path)
|
||||
file-serve
|
||||
req)
|
||||
(http-error http-reply/bad-request req
|
||||
"Path contains no home directory."))))
|
||||
|
||||
;;; (tilde-home-dir-handler-predicate path)
|
||||
;;; (tilde-home-dir-handler user-public-dir)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; If the car of the path is a tilde-marked home directory (e.g., "~kgk"),
|
||||
;;; do home-directory service as in HOME-DIR-HANDLER, otherwise punt to the
|
||||
;;; default handler.
|
||||
|
||||
(define (tilde-home-dir-handler-predicate path)
|
||||
(lambda (path)
|
||||
(and (pair? path) ; Is it a ~foo/...
|
||||
(let ((head (car path))) ; home-directory path?
|
||||
(and (> (string-length head) 0)
|
||||
(char=? (string-ref head 0) #\~))))))
|
||||
|
||||
(define (tilde-home-dir-handler user-public-dir)
|
||||
(lambda (path req)
|
||||
(let* ((tilde-home (car path)) ; Yes.
|
||||
(slen (string-length tilde-home))
|
||||
(subdir (string-append
|
||||
(http-homedir (substring tilde-home 1 slen) req)
|
||||
"/"
|
||||
user-public-dir)))
|
||||
(serve-rooted-file-path subdir (cdr path) file-serve req))))
|
||||
|
||||
|
||||
;;; Make a handler that serves files relative to a particular root
|
||||
;;; in the file system. You may follow symlinks, but you can't back up
|
||||
;;; past ROOT with ..'s.
|
||||
|
||||
(define (rooted-file-handler root)
|
||||
(lambda (path req)
|
||||
(serve-rooted-file-path root path file-serve req)))
|
||||
|
||||
;;; Dito, but also serve directory indices for directories without
|
||||
;;; index.html. ICON-NAME specifies how to generate the links to
|
||||
;;; various decorative icons for the listings. It can either be a
|
||||
;;; procedure which gets passed one of the icon tags in TAG->ICON and
|
||||
;;; is expected to return a link pointing to the icon. If it is a
|
||||
;;; string, that is taken as prefix to which the names from TAG->ICON
|
||||
;;; are appended.
|
||||
|
||||
(define (rooted-file-or-directory-handler root icon-name)
|
||||
(let ((file-serve-and-dir (file-server-and-dir icon-name)))
|
||||
(lambda (path req)
|
||||
(serve-rooted-file-path root path file-serve-and-dir req))))
|
||||
|
||||
|
||||
;;; The null path handler -- handles nothing, sends back an error reply.
|
||||
;;; Can be useful as the default in table-driven path handlers.
|
||||
|
||||
(define (null-path-handler path req)
|
||||
(http-error http-reply/not-found req))
|
||||
|
||||
|
||||
;;;; Support procs for the path handlers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;;; (SERVE-ROOTED-FILE-PATH root file-path req)
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Do a request for a file. The file-name is determined by appending the
|
||||
;;; the FILE-PATH list the string ROOT. E.g., if
|
||||
;;; ROOT = "/usr/shivers" FILE-PATH = ("a" "b" "c" "foo.html")
|
||||
;;; then we serve file
|
||||
;;; /usr/shivers/a/b/c/foo.html
|
||||
;;; Elements of FILE-PATH are *not allowed* to contain .. elements.
|
||||
;;; (N.B.: Although the ..'s can appear in relative URI's, /foo/../ path
|
||||
;;; sequences are processed away by the browser when the URI is converted
|
||||
;;; to an absolute URI before it is sent off to the server.)
|
||||
;;; It is possible to sneak a .. past this kind of front-end resolving by
|
||||
;;; encoding it (e.g., "foo%2F%2E%2E" for "foo/.."). If the client tries
|
||||
;;; this, SERVE-ROOTED-FILE-PATH will catch it, and abort the transaction.
|
||||
;;; So you cannot make the reference back up past ROOT. E.g., this is
|
||||
;;; not allowed:
|
||||
;;; FILE-PATH = ("a" "../.." "c" "foo.html")
|
||||
;;;
|
||||
;;; Only GET and HEAD ops are provided.
|
||||
;;; The URL's <search> component must be #f.
|
||||
;;; The file is served if the server has read or stat(2) access to it,
|
||||
;;; respectively. If the server is run as root, this might be a problem.
|
||||
;;;
|
||||
;;; FILE-SERVE is a procedure which gets passed the file name, the
|
||||
;;; path, and the HTTP request to serve the file propert after the
|
||||
;;; security checks. Look in ROOTED-FILE-HANDLER and
|
||||
;;; ROOTED-FILE-OR-DIRECTORY-HANDLER for examples on how to feed this.
|
||||
|
||||
(define (serve-rooted-file-path root file-path file-serve req)
|
||||
(if (http-url:search (request:url req))
|
||||
(http-error http-reply/bad-request req
|
||||
"Indexed search not provided for this URL.")
|
||||
|
||||
(cond ((dotdot-check root file-path) =>
|
||||
(lambda (fname) (file-serve fname file-path req)))
|
||||
(else
|
||||
(http-error http-reply/bad-request req
|
||||
"URL contains unresolvable ..'s.")))))
|
||||
|
||||
|
||||
;; Just (file-info fname) with error handling.
|
||||
|
||||
(define (stat-carefully fname req)
|
||||
(with-errno-handler
|
||||
((errno packet)
|
||||
((errno/noent)
|
||||
(http-error http-reply/not-found req))
|
||||
((errno/acces)
|
||||
(http-error http-reply/forbidden req)))
|
||||
(file-info fname #t)))
|
||||
|
||||
;;; A basic file request handler -- ship the dude the file. No fancy path
|
||||
;;; checking. That has presumably been taken care of. This handler only
|
||||
;;; takes care of GET and HEAD methods.
|
||||
|
||||
(define (file-serve-or-dir fname file-path req directory-serve)
|
||||
(if (file-name-directory? fname) ; Simple index generation.
|
||||
(directory-serve fname file-path req)
|
||||
|
||||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((or (string=? request-method "GET")
|
||||
(string=? request-method "HEAD")) ; Absolutely.
|
||||
(let ((info (stat-carefully fname req)))
|
||||
(case (file-info:type info)
|
||||
|
||||
((regular fifo socket)
|
||||
(send-file fname info req))
|
||||
|
||||
((directory) ; Send back a redirection "foo" -> "foo/"
|
||||
(http-error http-reply/moved-perm req
|
||||
(string-append (request:uri req) "/")
|
||||
(string-append (http-url->string (request:url req))
|
||||
"/")))
|
||||
|
||||
(else (http-error http-reply/forbidden req)))))
|
||||
|
||||
(else (http-error http-reply/method-not-allowed req))))))
|
||||
|
||||
(define (directory-index-serve fname file-path req)
|
||||
(file-serve (string-append fname "index.html") file-path req))
|
||||
|
||||
(define (file-serve fname file-path req)
|
||||
(file-serve-or-dir fname file-path req directory-index-serve))
|
||||
|
||||
(define (tag->alt tag)
|
||||
(case tag
|
||||
((directory) "[DIR]")
|
||||
((text) "[TXT]")
|
||||
((doc) "[DOC]")
|
||||
((image) "[IMG]")
|
||||
((movie) "[MVI]")
|
||||
((audio) "[AU ]")
|
||||
((archive) "[TAR]")
|
||||
((compressed) "[ZIP]")
|
||||
((uu) "[UU ]")
|
||||
((binhex) "[HQX]")
|
||||
((binary) "[BIN]")
|
||||
(else "[ ]")))
|
||||
|
||||
;; These icons can, for example, be found in the cern-httpd-3.0
|
||||
;; distribution at http://www.w3.org/pub/WWW/Daemon/
|
||||
|
||||
(define (tag->icon tag)
|
||||
(case tag
|
||||
((directory) "directory.xbm")
|
||||
((text) "text.xbm")
|
||||
((doc) "doc.xbm")
|
||||
((image) "image.xbm")
|
||||
((movie) "movie.xbm")
|
||||
((audio) "sound.xbm")
|
||||
((archive) "tar.xbm")
|
||||
((compressed) "compressed.xbm")
|
||||
((uu) "uu.xbm")
|
||||
((binhex) "binhex.xbm")
|
||||
((binary) "binary.xbm")
|
||||
((blank) "blank.xbm")
|
||||
((back) "back.xbm")
|
||||
(else "unknown.xbm")))
|
||||
|
||||
(define (file-extension->tag fname)
|
||||
(let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".txt") 'text)
|
||||
((or (string-ci=? ext ".doc")
|
||||
(string-ci=? ext ".html")
|
||||
(string-ci=? ext ".rtf")
|
||||
(string-ci=? ext ".tex")) 'doc)
|
||||
((or (string-ci=? ext ".gif")
|
||||
(string-ci=? ext ".jpg")
|
||||
(string-ci=? ext ".jpeg")
|
||||
(string-ci=? ext ".tiff")
|
||||
(string-ci=? ext ".tif")) 'image)
|
||||
((or (string-ci=? ext ".mpeg")
|
||||
(string-ci=? ext ".mpg")) 'movie)
|
||||
((or (string-ci=? ext ".au")
|
||||
(string-ci=? ext ".snd")
|
||||
(string-ci=? ext ".wav")) 'audio)
|
||||
((or (string-ci=? ext ".tar")
|
||||
(string-ci=? ext ".zip")
|
||||
(string-ci=? ext ".zoo")) 'archive)
|
||||
((or (string-ci=? ext ".gz")
|
||||
(string-ci=? ext ".Z")
|
||||
(string-ci=? ext ".z")) 'compressed)
|
||||
((string-ci=? ext ".uu") 'uu)
|
||||
((string-ci=? ext ".hqx") 'binhex)
|
||||
(else 'binary))))
|
||||
|
||||
(define (file-tag fname type)
|
||||
(case type
|
||||
((regular fifo socket) (file-extension->tag fname))
|
||||
((directory) 'directory)
|
||||
(else 'unknown)))
|
||||
|
||||
(define (time->directory-index-date-string time)
|
||||
(format-date "~d-~b-~y ~H:~M:~S GMT" (date time 0)))
|
||||
|
||||
(define (read-max-lines fname max)
|
||||
(call-with-input-file
|
||||
fname
|
||||
(lambda (port)
|
||||
(let loop ((r "") (i max))
|
||||
(if (zero? i)
|
||||
r
|
||||
(let ((line (read-line port)))
|
||||
(if (eof-object? line)
|
||||
r
|
||||
(loop (string-append r " " line) (- i 1)))))))))
|
||||
|
||||
(define (string-cut s n)
|
||||
(if (>= (string-length s) n)
|
||||
(substring s 0 n)
|
||||
s))
|
||||
|
||||
(define html-file-header
|
||||
(let ((title-tag-regexp (make-regexp "<[Tt][Ii][Tt][Ll][Ee]>"))
|
||||
(title-close-tag-regexp (make-regexp "</[Tt][Ii][Tt][Ll][Ee]>")))
|
||||
(lambda (fname n)
|
||||
(let ((stuff (read-max-lines fname 10)))
|
||||
(cond
|
||||
((regexp-exec title-tag-regexp stuff)
|
||||
=> (lambda (open-match)
|
||||
(cond
|
||||
((regexp-exec title-close-tag-regexp stuff
|
||||
(match:end open-match 0))
|
||||
=> (lambda (close-match)
|
||||
(string-cut (substring stuff
|
||||
(match:end open-match 0)
|
||||
(match:start close-match 0))
|
||||
n)))
|
||||
(else (string-cut (substring stuff
|
||||
(match:end open-match 0)
|
||||
(string-length stuff))
|
||||
n)))))
|
||||
(else ""))))))
|
||||
|
||||
(define (file-documentation fname n)
|
||||
(cond
|
||||
((file-extension->content-type fname)
|
||||
=> (lambda (content-type)
|
||||
(if (and (string=? content-type "text/html" )
|
||||
(file-readable? fname))
|
||||
(html-file-header fname n)
|
||||
"")))
|
||||
(else "")))
|
||||
|
||||
(define (directory-index req dir icon-name)
|
||||
|
||||
(define (pad-file-name file)
|
||||
(write-string (make-string (- 21 (string-length file))
|
||||
#\space)))
|
||||
|
||||
(define (emit-file-name file)
|
||||
(let ((l (string-length file)))
|
||||
(if (<= l 20)
|
||||
(emit-text file)
|
||||
(emit-text (substring file 0 20)))))
|
||||
|
||||
(define (index-entry file)
|
||||
(let* ((fname (directory-as-file-name (string-append dir file)))
|
||||
(info (stat-carefully fname req))
|
||||
(type (file-info:type info))
|
||||
(size (file-info:size info))
|
||||
(tag (file-tag file type)))
|
||||
(emit-tag #t 'img
|
||||
(cons 'src (icon-name tag))
|
||||
(cons 'alt (tag->alt tag)))
|
||||
(with-tag #t a ((href file))
|
||||
(emit-file-name file))
|
||||
(pad-file-name file)
|
||||
(emit-text (time->directory-index-date-string (file-info:mtime info)))
|
||||
(if size
|
||||
(let* ((size-string
|
||||
(string-append (number->string (quotient size 1024))
|
||||
"K"))
|
||||
(size-string
|
||||
(if (<= (string-length size-string) 7)
|
||||
size-string
|
||||
(string-append (number->string (quotient size (* 1024 1024)))
|
||||
"M")))
|
||||
(size-string
|
||||
(if (<= (string-length size-string) 8)
|
||||
(string-append
|
||||
(make-string (- 8 (string-length size-string)) #\space)
|
||||
size-string)
|
||||
size-string)))
|
||||
(write-string size-string))
|
||||
(write-string (make-string 8 #\space)))
|
||||
(write-char #\space)
|
||||
(emit-text (file-documentation fname 24))
|
||||
(newline)))
|
||||
|
||||
(let ((files (with-errno-handler
|
||||
((errno packet)
|
||||
((errno/acces)
|
||||
(http-error http-reply/forbidden req)))
|
||||
(directory-files dir))))
|
||||
(for-each index-entry files)
|
||||
(length files)))
|
||||
|
||||
(define (directory-server icon-name)
|
||||
(let ((icon-name
|
||||
(cond
|
||||
((procedure? icon-name) icon-name)
|
||||
((string? icon-name)
|
||||
(lambda (tag)
|
||||
(string-append icon-name (tag->icon tag))))
|
||||
(else tag->icon))))
|
||||
(lambda (fname file-path req)
|
||||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((or (string=? request-method "GET")
|
||||
(string=? request-method "HEAD"))
|
||||
|
||||
(if (not (eq? 'directory
|
||||
(file-info:type (stat-carefully fname req))))
|
||||
(http-error http-reply/forbidden req))
|
||||
|
||||
(if (not (v0.9-request? req))
|
||||
(begin
|
||||
(begin-http-header #t http-reply/ok)
|
||||
(write-string "Content-type: text/html\r\n")
|
||||
(write-string "\r\n")))
|
||||
|
||||
(with-tag #t html ()
|
||||
(let ((title (string-append "Index of /"
|
||||
(string-join file-path "/"))))
|
||||
(with-tag #t head ()
|
||||
(emit-title #t title))
|
||||
(with-tag #t body ()
|
||||
(emit-header #t 1 title)
|
||||
(with-tag #t pre ()
|
||||
(emit-tag #t 'img
|
||||
(cons 'src (icon-name 'blank))
|
||||
(cons 'alt " "))
|
||||
(write-string "Name ")
|
||||
(write-string "Last modified ")
|
||||
(write-string "Size ")
|
||||
(write-string "Description")
|
||||
(emit-tag #t 'hr)
|
||||
(emit-tag #t 'img
|
||||
(cons 'src (icon-name 'back))
|
||||
(cons 'alt "[UP ]"))
|
||||
(if (not (null? file-path))
|
||||
(begin
|
||||
(with-tag #t a ((href ".."))
|
||||
(write-string "Parent directory"))
|
||||
(newline)))
|
||||
(let ((n-files (directory-index req fname icon-name)))
|
||||
(emit-tag #t 'hr)
|
||||
(format #t "~d files" n-files)))))))
|
||||
(else (http-error http-reply/method-not-allowed req)))))))
|
||||
|
||||
(define (index-or-directory-server icon-name)
|
||||
(let ((directory-serve (directory-server icon-name)))
|
||||
(lambda (fname file-path req)
|
||||
(let ((index-fname (string-append fname "index.html")))
|
||||
|
||||
(if (file-readable? index-fname)
|
||||
(file-serve index-fname file-path req)
|
||||
(directory-serve fname file-path req))))))
|
||||
|
||||
(define (file-server-and-dir icon-name)
|
||||
(let ((index-or-directory-serve (index-or-directory-server icon-name)))
|
||||
(lambda (fname file-path req)
|
||||
(file-serve-or-dir fname file-path req index-or-directory-serve))))
|
||||
|
||||
;;; Look up user's home directory, generating an HTTP error reply if you lose.
|
||||
|
||||
(define (http-homedir username req)
|
||||
(with-fatal-error-handler (lambda (c decline)
|
||||
(apply http-error http-reply/bad-request req
|
||||
"Couldn't find user's home directory."
|
||||
(condition-stuff c)))
|
||||
|
||||
(home-dir username)))
|
||||
|
||||
|
||||
(define (send-file filename info req)
|
||||
(with-errno-handler ((errno packet)
|
||||
((errno/acces)
|
||||
(http-error http-reply/forbidden req))
|
||||
((errno/noent)
|
||||
(http-error http-reply/not-found req)))
|
||||
(call-with-input-file filename
|
||||
(lambda (in)
|
||||
(let ((out (current-output-port)))
|
||||
(if (not (v0.9-request? req))
|
||||
(begin
|
||||
(begin-http-header out http-reply/ok)
|
||||
(receive (filename content-encoding)
|
||||
(file-extension->content-encoding filename)
|
||||
(if content-encoding
|
||||
(format out "Content-encoding: ~A\r~%"
|
||||
content-encoding))
|
||||
(cond ((file-extension->content-type filename) =>
|
||||
(lambda (ct)
|
||||
(format out "Content-type: ~A\r~%" ct)))))
|
||||
(format out "Last-modified: ~A\r~%"
|
||||
(time->http-date-string (file-info:mtime info)))
|
||||
(format out "Content-length: ~D\r~%" (file-info:size info))
|
||||
(write-string "\r\n" out)))
|
||||
(copy-inport->outport in out))))))
|
||||
|
||||
|
||||
;;; Assemble a filename from ROOT and the elts of PATH-LIST.
|
||||
;;; If the assembled filename contains a .. subdirectory, return #f,
|
||||
;;; otw return the filename.
|
||||
|
||||
(define dotdot-check
|
||||
(let ((dotdot-re (make-regexp "(^|/)\\.\\.($|/)"))) ; Matches a .. subdir.
|
||||
(lambda (root path-list)
|
||||
(let ((fname (if (null? path-list) root ; Bogus hack.
|
||||
(string-append (file-name-as-directory root)
|
||||
(string-join path-list "/")))))
|
||||
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
|
||||
fname)))))
|
||||
|
||||
|
||||
(define (file-extension->content-type fname)
|
||||
(let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".html") "text/html")
|
||||
((string-ci=? ext ".txt") "text/plain")
|
||||
((string-ci=? ext ".gif") "image/gif")
|
||||
((string-ci=? ext ".png") "image/png")
|
||||
((or (string-ci=? ext ".jpg")
|
||||
(string-ci=? ext ".jpeg")) "image/jpeg")
|
||||
((or (string-ci=? ext ".tiff")
|
||||
(string-ci=? ext ".tif")) "image/tif")
|
||||
((string-ci=? ext ".rtf") "text/rtf")
|
||||
((or (string-ci=? ext ".mpeg")
|
||||
(string-ci=? ext ".mpg")) "video/mpeg")
|
||||
((or (string-ci=? ext ".au")
|
||||
(string-ci=? ext ".snd")) "audio/basic")
|
||||
((string-ci=? ext ".wav") "audio/x-wav")
|
||||
((string-ci=? ext ".dvi") "application/x-dvi")
|
||||
((or (string-ci=? ext ".tex")
|
||||
(string-ci=? ext ".latex")) "application/latex")
|
||||
((string-ci=? ext ".zip") "application/zip")
|
||||
((string-ci=? ext ".tar") "application/tar")
|
||||
((string-ci=? ext ".ps") "application/postscript")
|
||||
((string-ci=? ext ".pdf") "application/pdf")
|
||||
(else "application/octet-stream"))))
|
||||
|
||||
(define (file-extension->content-encoding fname)
|
||||
(cond
|
||||
((let ((ext (file-name-extension fname)))
|
||||
(cond
|
||||
((string-ci=? ext ".Z") "x-compress")
|
||||
((string-ci=? ext ".gz") "x-gzip")
|
||||
(else #f)))
|
||||
=> (lambda (encoding)
|
||||
(values (file-name-sans-extension fname) encoding)))
|
||||
(else (values fname #f))))
|
||||
|
||||
;;; Timeout on network writes?
|
||||
|
||||
(define (copy-inport->outport in out)
|
||||
(let ((buf (make-string server/buffer-size)))
|
||||
(let loop ()
|
||||
(cond ((read-string! buf in) => (lambda (nchars)
|
||||
(write-string buf out 0 nchars)
|
||||
(loop))))))
|
||||
(force-output out))
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
(define-record-type httpd-options :httpd-options
|
||||
(really-make-httpd-options port
|
||||
root-directory
|
||||
icon-name
|
||||
fqdn
|
||||
reported-port
|
||||
path-handler
|
||||
|
|
@ -20,6 +21,14 @@
|
|||
set-httpd-options-port!)
|
||||
(root-directory httpd-options-root-directory
|
||||
set-httpd-options-root-directory!)
|
||||
;; ICON-NAME specifies how to generate the links to
|
||||
;; various decorative icons for the listings. It can either be a
|
||||
;; procedure which gets passed one of the icon tags in TAG->ICON and
|
||||
;; is expected to return a link pointing to the icon. If it is a
|
||||
;; string, that is taken as prefix to which the names from TAG->ICON
|
||||
;; are appended.
|
||||
(icon-name httpd-options-icon-name
|
||||
set-httpd-options-icon-name!)
|
||||
(fqdn httpd-options-fqdn
|
||||
set-httpd-options-fqdn!)
|
||||
(reported-port httpd-options-reported-port
|
||||
|
|
@ -38,15 +47,16 @@
|
|||
(define (make-httpd-options)
|
||||
(really-make-httpd-options 80 ; port
|
||||
"/" ; root-directory
|
||||
#f ; icon-name
|
||||
#f ; fqdn
|
||||
#f ; reported-port
|
||||
#f ; path-handler
|
||||
#f ; server-admin
|
||||
#f ; simultaneous-requests
|
||||
"/logfile.log" ; name of the logfile
|
||||
; string: filename of logfile (directory must exist)
|
||||
; output-port: log to this port (e.g. (current-error-port))
|
||||
; #f: no logging
|
||||
#f
|
||||
; string: filename of logfile (directory must exist)
|
||||
; output-port: log to this port (e.g. (current-error-port))
|
||||
; #f: no logging
|
||||
#t ; Do syslogging?
|
||||
#t)) ; Write host names instead of IPs in logfiles?
|
||||
|
||||
|
|
@ -58,6 +68,8 @@
|
|||
(httpd-options-port options))
|
||||
(set-httpd-options-root-directory! new-options
|
||||
(httpd-options-root-directory options))
|
||||
(set-httpd-options-icon-name! new-options
|
||||
(httpd-options-icon-name options))
|
||||
(set-httpd-options-fqdn! new-options
|
||||
(httpd-options-fqdn options))
|
||||
(set-httpd-options-reported-port! new-options
|
||||
|
|
@ -91,6 +103,8 @@
|
|||
(make-httpd-options-transformer set-httpd-options-port!))
|
||||
(define with-root-directory
|
||||
(make-httpd-options-transformer set-httpd-options-root-directory!))
|
||||
(define with-icon-name
|
||||
(make-httpd-options-transformer set-httpd-options-icon-name!))
|
||||
(define with-fqdn
|
||||
(make-httpd-options-transformer set-httpd-options-fqdn!))
|
||||
(define with-reported-port
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
(define-record-type :http-response
|
||||
(make-response code message seconds mime extras body)
|
||||
response?
|
||||
(code response-code)
|
||||
(message response-message)
|
||||
(seconds response-seconds)
|
||||
(mime response-mime)
|
||||
(extras response-extras)
|
||||
(body response-body))
|
||||
|
||||
(define-record-type :http-writer-body
|
||||
(make-writer-body proc)
|
||||
writer-body?
|
||||
(proc writer-body-proc))
|
||||
|
||||
(define (display-http-body body port options)
|
||||
((writer-body-proc body) port options))
|
||||
|
||||
|
|
@ -4,16 +4,7 @@
|
|||
(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.
|
||||
(define (title-html out message)
|
||||
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
|
||||
(format out "<BODY>~%<H1>~A</H1>~%" message))
|
||||
|
||||
|
|
|
|||
|
|
@ -249,11 +249,12 @@
|
|||
|
||||
(define-interface httpd-core-interface
|
||||
(export httpd
|
||||
send-http-error-reply))
|
||||
make-http-error-response))
|
||||
|
||||
(define-interface httpd-make-options-interface
|
||||
(export with-port
|
||||
with-root-directory
|
||||
with-icon-name
|
||||
with-fqdn
|
||||
with-reported-port
|
||||
with-path-handler
|
||||
|
|
@ -266,6 +267,7 @@
|
|||
(define-interface httpd-read-options-interface
|
||||
(export httpd-options-port
|
||||
httpd-options-root-directory
|
||||
httpd-options-icon-name
|
||||
httpd-options-fqdn
|
||||
httpd-options-reported-port
|
||||
httpd-options-path-handler
|
||||
|
|
@ -349,29 +351,34 @@
|
|||
|
||||
(define-interface httpd-text-generation-interface
|
||||
(export time->http-date-string
|
||||
begin-http-header
|
||||
title-html))
|
||||
|
||||
(define-interface httpd-responses-interface
|
||||
(export make-response response?
|
||||
response-code
|
||||
response-message
|
||||
response-seconds
|
||||
response-mime
|
||||
response-extras
|
||||
response-body
|
||||
|
||||
make-writer-body writer-body?
|
||||
display-http-body))
|
||||
|
||||
(define-interface httpd-basic-handlers-interface
|
||||
(export make-request-handler
|
||||
make-path-handler
|
||||
make-hostname-handler
|
||||
make-path-prefix-handler
|
||||
alist-path-dispatcher
|
||||
home-dir-handler
|
||||
alist-path-dispatcher))
|
||||
|
||||
(define-interface httpd-file-directory-handlers-interface
|
||||
(export home-dir-handler
|
||||
tilde-home-dir-handler
|
||||
tilde-home-dir-handler-predicate
|
||||
rooted-file-handler
|
||||
rooted-file-or-directory-handler
|
||||
null-path-handler
|
||||
serve-rooted-file-path
|
||||
file-serve
|
||||
file-server-and-dir
|
||||
http-homedir
|
||||
send-file
|
||||
dotdot-check
|
||||
file-extension->content-type
|
||||
copy-inport->outport))
|
||||
null-path-handler))
|
||||
|
||||
(define-interface seval-handler-interface
|
||||
(export seval-handler))
|
||||
|
|
@ -658,6 +665,8 @@
|
|||
httpd-logging
|
||||
httpd-request
|
||||
httpd-reply-codes
|
||||
httpd-constants
|
||||
httpd-responses
|
||||
httpd-text-generation
|
||||
scheme)
|
||||
(files (httpd core)))
|
||||
|
|
@ -725,23 +734,37 @@
|
|||
scsh) ; format-date
|
||||
(files (httpd text-generation)))
|
||||
|
||||
(define-structure httpd-responses httpd-responses-interface
|
||||
(open scheme
|
||||
srfi-9)
|
||||
(files (httpd response)))
|
||||
|
||||
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
||||
(open scsh ; syscalls
|
||||
formats ; FORMAT
|
||||
(open scheme scsh
|
||||
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
|
||||
handle-fatal-error ; WITH-FATAL-ERROR-HANDLER
|
||||
string-lib ; STRING-JOIN
|
||||
list-lib ; FOLD-RIGHT
|
||||
rfc822 ; GET-HEADER
|
||||
scheme)
|
||||
srfi-1 ; FOLD-RIGHT
|
||||
srfi-13 ; STRING-TRIM
|
||||
)
|
||||
(files (httpd handlers)))
|
||||
|
||||
(define-structure httpd-file-directory-handlers httpd-file-directory-handlers-interface
|
||||
(open scheme scsh
|
||||
httpd-core
|
||||
httpd-request
|
||||
httpd-reply-codes
|
||||
httpd-responses
|
||||
httpd-text-generation
|
||||
httpd-error
|
||||
httpd-read-options
|
||||
url
|
||||
htmlout
|
||||
crlf-io
|
||||
srfi-13 ; STRING-JOIN
|
||||
conditions
|
||||
handle-fatal-error
|
||||
)
|
||||
(files (httpd file-dir-handler)))
|
||||
|
||||
(define-structure seval-handler seval-handler-interface
|
||||
(open scsh ; syscalls & INDEX
|
||||
httpd-error
|
||||
|
|
|
|||
Loading…
Reference in New Issue