sunet can be used with scsh 0.6 now (hopefully).
explicitly named every interface moved TOOTHLESS.SCM to MODULES.SCM removed macros from CONDITIONALS.SCM (UNLESS, WHEN, ?, SWITCH, SWITCHQ) thereby removed conditionals.scm and the modules SWITCH-SYNTAX and CONDHAX.
This commit is contained in:
parent
a741498c59
commit
6c702e9a03
|
@ -82,13 +82,14 @@
|
||||||
;;; This only works for GET and POST methods.
|
;;; This only works for GET and POST methods.
|
||||||
|
|
||||||
(define (cgi-form-query)
|
(define (cgi-form-query)
|
||||||
(switch string=? (getenv "REQUEST_METHOD")
|
(let ((request-method (getenv "REQUEST_METHOD")))
|
||||||
|
(cond
|
||||||
|
|
||||||
(("GET")
|
((string=? request-method "GET")
|
||||||
(parse-html-form-query (getenv "QUERY_STRING")))
|
(parse-html-form-query (getenv "QUERY_STRING")))
|
||||||
|
|
||||||
(("POST")
|
((string=? request-method "POST")
|
||||||
(let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
|
(let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
|
||||||
(parse-html-form-query (read-string nchars))))
|
(parse-html-form-query (read-string nchars))))
|
||||||
|
|
||||||
(else (error "Method not handled.")))) ; Don't be calling me.
|
(else (error "Method not handled."))))) ; Don't be calling me.
|
||||||
|
|
|
@ -112,22 +112,25 @@
|
||||||
filename)))))
|
filename)))))
|
||||||
|
|
||||||
(http-log "search: ~s, argv: ~s~%" search argv)
|
(http-log "search: ~s, argv: ~s~%" search argv)
|
||||||
(switch string=? (request:method req)
|
(let ((request-method (request:method req)))
|
||||||
(("GET" "POST") ; Could do others also.
|
(cond
|
||||||
(if nph?
|
((or (string=? request-method "GET")
|
||||||
(wait (fork doit))
|
(string=? request-method "POST")) ; Could do others also.
|
||||||
(cgi-send-reply (run/port* doit) req)))
|
(if nph?
|
||||||
|
(wait (fork doit))
|
||||||
(else (http-error http-reply/method-not-allowed req))))
|
(cgi-send-reply (run/port* doit) req)))
|
||||||
|
|
||||||
|
(else (http-error http-reply/method-not-allowed req)))))
|
||||||
|
|
||||||
(http-error http-reply/bad-request req "Empty CGI script"))))
|
(http-error http-reply/bad-request req "Empty CGI script"))))
|
||||||
|
|
||||||
|
|
||||||
(define (split-and-decode-search-spec s)
|
(define (split-and-decode-search-spec s)
|
||||||
(let recur ((i 0))
|
(let recur ((i 0))
|
||||||
(? ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
(cond
|
||||||
|
((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||||
(recur (+ j 1)))))
|
(recur (+ j 1)))))
|
||||||
(else (list (unescape-uri s i (string-length s)))))))
|
(else (list (unescape-uri s i (string-length s)))))))
|
||||||
|
|
||||||
|
|
||||||
;;; Compute the CGI scripts' process environment by adding the standard CGI
|
;;; Compute the CGI scripts' process environment by adding the standard CGI
|
||||||
|
@ -190,26 +193,26 @@
|
||||||
|
|
||||||
,@request-invariant-cgi-env ; Stuff that never changes (see below).
|
,@request-invariant-cgi-env ; Stuff that never changes (see below).
|
||||||
|
|
||||||
,@(? ((http-url:search (request:url req)) =>
|
,@(cond ((http-url:search (request:url req)) =>
|
||||||
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
||||||
(else '()))
|
(else '()))
|
||||||
|
|
||||||
,@(? ((get-header headers 'content-type) =>
|
,@(cond ((get-header headers 'content-type) =>
|
||||||
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
|
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
|
||||||
(else '()))
|
(else '()))
|
||||||
|
|
||||||
,@(? ((get-header headers 'content-length) =>
|
|
||||||
(lambda (cl) ; Skip initial whitespace (& other non-digits).
|
|
||||||
(let ((first-digit (char-set-index cl char-set:numeric))
|
|
||||||
(cl-len (string-length cl)))
|
|
||||||
(if first-digit
|
|
||||||
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
|
|
||||||
(http-error http-reply/bad-request
|
|
||||||
req
|
|
||||||
"Illegal Content-length: header.")))))
|
|
||||||
|
|
||||||
(else '()))
|
|
||||||
|
|
||||||
|
,@(cond ((get-header headers 'content-length) =>
|
||||||
|
(lambda (cl) ; Skip initial whitespace (& other non-digits).
|
||||||
|
(let ((first-digit (char-set-index cl char-set:numeric))
|
||||||
|
(cl-len (string-length cl)))
|
||||||
|
(if first-digit
|
||||||
|
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
|
||||||
|
(http-error http-reply/bad-request
|
||||||
|
req
|
||||||
|
"Illegal Content-length: header.")))))
|
||||||
|
|
||||||
|
(else '()))
|
||||||
|
|
||||||
. ,(env->alist))))))
|
. ,(env->alist))))))
|
||||||
|
|
||||||
(define request-invariant-cgi-env #f)
|
(define request-invariant-cgi-env #f)
|
||||||
|
@ -239,29 +242,32 @@
|
||||||
(ctype (get-header headers 'content-type)) ; The script headers
|
(ctype (get-header headers 'content-type)) ; The script headers
|
||||||
(loc (get-header headers 'location))
|
(loc (get-header headers 'location))
|
||||||
(stat (let ((stat-lines (get-header-lines headers 'status)))
|
(stat (let ((stat-lines (get-header-lines headers 'status)))
|
||||||
(? ((not (pair? stat-lines)) ; No status header.
|
(cond
|
||||||
"200 The idiot CGI script left out the status line.")
|
((not (pair? stat-lines)) ; No status header.
|
||||||
((null? (cdr stat-lines)) ; One line status header.
|
"200 The idiot CGI script left out the status line.")
|
||||||
(car stat-lines))
|
((null? (cdr stat-lines)) ; One line status header.
|
||||||
(else ; Vas ist das?
|
(car stat-lines))
|
||||||
(http-error http-reply/internal-error req
|
(else ; Vas ist das?
|
||||||
"CGI script generated multi-line status header")))))
|
(http-error http-reply/internal-error req
|
||||||
|
"CGI script generated multi-line status header")))))
|
||||||
(out (current-output-port)))
|
(out (current-output-port)))
|
||||||
|
|
||||||
(http-log "headers: ~s~%" headers)
|
(http-log "headers: ~s~%" headers)
|
||||||
;; Send the reply header back to the client
|
;; Send the reply header back to the client
|
||||||
;; (unless it's a headerless HTTP 0.9 reply).
|
;; (unless it's a headerless HTTP 0.9 reply).
|
||||||
(unless (v0.9-request? req)
|
(if (not (v0.9-request? req))
|
||||||
(format out "HTTP/1.0 ~a\r~%" stat)
|
(begin
|
||||||
(if ctype (format out "Content-type: ~a\r~%" ctype))
|
(format out "HTTP/1.0 ~a\r~%" stat)
|
||||||
(if loc (format out "Location: ~a\r~%" loc))
|
(if ctype (format out "Content-type: ~a\r~%" ctype))
|
||||||
(write-crlf out))
|
(if loc (format out "Location: ~a\r~%" loc))
|
||||||
|
(write-crlf out)))
|
||||||
|
|
||||||
(http-log "request:method=~a~%" (request:method req))
|
(http-log "request:method=~a~%" (request:method req))
|
||||||
;; Copy the reply body back to the client and close the script port
|
;; Copy the reply body back to the client and close the script port
|
||||||
;; (unless it's a bodiless HEAD transaction).
|
;; (unless it's a bodiless HEAD transaction).
|
||||||
(unless (string=? (request:method req) "HEAD")
|
(if (not (string=? (request:method req) "HEAD"))
|
||||||
(copy-inport->outport script-port out)
|
(begin
|
||||||
(close-input-port script-port))))
|
(copy-inport->outport script-port out)
|
||||||
|
(close-input-port script-port)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -145,7 +145,7 @@
|
||||||
(cons (ascii->char 34) """)))
|
(cons (ascii->char 34) """)))
|
||||||
|
|
||||||
(define *html-entities*
|
(define *html-entities*
|
||||||
(chars->char-set (map car *html-entity-alist*)))
|
(list->char-set (map car *html-entity-alist*)))
|
||||||
|
|
||||||
(define *html-entity-table*
|
(define *html-entity-table*
|
||||||
(let ((v (make-vector 256 #f)))
|
(let ((v (make-vector 256 #f)))
|
||||||
|
|
106
httpd-core.scm
106
httpd-core.scm
|
@ -191,7 +191,7 @@
|
||||||
(fatal-syntax-error "EOF while parsing request.")
|
(fatal-syntax-error "EOF while parsing request.")
|
||||||
|
|
||||||
(let* ((elts (string->words line)) ; Split at white-space.
|
(let* ((elts (string->words line)) ; Split at white-space.
|
||||||
(version (switch = (length elts)
|
(version (case (length elts)
|
||||||
((2) '(0 . 9))
|
((2) '(0 . 9))
|
||||||
((3) (parse-http-version (caddr elts)))
|
((3) (parse-http-version (caddr elts)))
|
||||||
(else (fatal-syntax-error "Bad HTTP version.")))))
|
(else (fatal-syntax-error "Bad HTTP version.")))))
|
||||||
|
@ -386,78 +386,90 @@
|
||||||
(if html-ok? (write-string "Content-type: text/html\r\n" out))
|
(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.
|
;; If html-ok?, we must send back some html, with the <body> tag unclosed.
|
||||||
(switch = reply-code
|
(cond
|
||||||
|
|
||||||
;; This error reply requires two args: message is the new URI: field,
|
;; This error reply requires two args: message is the new URI: field,
|
||||||
;; and the first EXTRA is the older Location: field.
|
;; and the first EXTRA is the older Location: field.
|
||||||
((http-reply/moved-temp http-reply/moved-perm)
|
((or (= reply-code http-reply/moved-temp)
|
||||||
(when new-protocol?
|
(= reply-code http-reply/moved-perm))
|
||||||
(format out "URI: ~A\r~%" message)
|
(if new-protocol?
|
||||||
(format out "Location: ~A\r~%" (car extras)))
|
(begin
|
||||||
(when html-ok?
|
(format out "URI: ~A\r~%" message)
|
||||||
|
(format out "Location: ~A\r~%" (car extras))))
|
||||||
|
(if html-ok?
|
||||||
|
(begin
|
||||||
(title-html out "Document moved" new-protocol?)
|
(title-html out "Document moved" new-protocol?)
|
||||||
(format out
|
(format out
|
||||||
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
|
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%"
|
||||||
(if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
|
(if (= reply-code http-reply/moved-temp) "temporarily" "permanently")
|
||||||
message)))
|
message))))
|
||||||
|
|
||||||
((http-reply/bad-request)
|
((= reply-code http-reply/bad-request)
|
||||||
(when html-ok?
|
(if html-ok?
|
||||||
|
(begin
|
||||||
(generic-title)
|
(generic-title)
|
||||||
(write-string "<P>Client sent a query that this server could not understand.\n"
|
(write-string "<P>Client sent a query that this server could not understand.\n"
|
||||||
out)
|
out)
|
||||||
(if message (format out "<BR>~%Reason: ~A~%" message))))
|
(if message (format out "<BR>~%Reason: ~A~%" message)))))
|
||||||
|
|
||||||
((http-reply/unauthorized)
|
((= reply-code http-reply/unauthorized)
|
||||||
(if new-protocol?
|
(if new-protocol?
|
||||||
(format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
|
(format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
|
||||||
(when html-ok?
|
(if html-ok?
|
||||||
(title-html out "Authorization Required" new-protocol?)
|
(begin
|
||||||
(write-string "<P>Browser not authentication-capable or\n" out)
|
(title-html out "Authorization Required" new-protocol?)
|
||||||
(write-string "authentication failed.\n" out)
|
(write-string "<P>Browser not authentication-capable or\n" out)
|
||||||
(if message (format out "~a~%" message))))
|
(write-string "authentication failed.\n" out)
|
||||||
|
(if message (format out "~a~%" message)))))
|
||||||
|
|
||||||
((http-reply/forbidden)
|
((= reply-code http-reply/forbidden)
|
||||||
(unless html-ok?
|
(if (not html-ok?)
|
||||||
(title-html out "Request not allowed." new-protocol?)
|
(begin
|
||||||
(format out "Your client does not have permission to perform a ~A~%"
|
(title-html out "Request not allowed." new-protocol?)
|
||||||
(request:method req))
|
(format out
|
||||||
(format out "operation on url ~a.~%" (request:uri req))
|
"Your client does not have permission to perform a ~A~%"
|
||||||
(if message (format out "<P>~%~a~%" message))))
|
(request:method req))
|
||||||
|
(format out "operation on url ~a.~%" (request:uri req))
|
||||||
|
(if message (format out "<P>~%~a~%" message)))))
|
||||||
|
|
||||||
|
((= 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)))))
|
||||||
|
|
||||||
((http-reply/not-found)
|
((= reply-code http-reply/internal-error)
|
||||||
(when html-ok?
|
|
||||||
(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))))
|
|
||||||
|
|
||||||
((http-reply/internal-error)
|
|
||||||
(format (current-error-port) "ERROR: ~A~%" message)
|
(format (current-error-port) "ERROR: ~A~%" message)
|
||||||
(when html-ok?
|
(if html-ok?
|
||||||
(generic-title)
|
(begin
|
||||||
(format out "The server encountered an internal error or
|
(generic-title)
|
||||||
|
(format out "The server encountered an internal error or
|
||||||
misconfiguration and was unable to complete your request.
|
misconfiguration and was unable to complete your request.
|
||||||
<P>
|
<P>
|
||||||
Please inform the server administrator, ~A, of the circumstances leading to
|
Please inform the server administrator, ~A, of the circumstances leading to
|
||||||
the error, and time it occured.~%"
|
the error, and time it occured.~%"
|
||||||
server/admin)
|
server/admin)
|
||||||
(if message (format out "<P>~%~a~%" message))))
|
(if message (format out "<P>~%~a~%" message)))))
|
||||||
|
|
||||||
((http-reply/not-implemented)
|
((= reply-code http-reply/not-implemented)
|
||||||
(when html-ok?
|
(if html-ok?
|
||||||
(generic-title)
|
(begin
|
||||||
(format out "This server does not currently implement
|
(generic-title)
|
||||||
|
(format out "This server does not currently implement
|
||||||
the requested method (~A).~%"
|
the requested method (~A).~%"
|
||||||
(request:method req))
|
(request:method req))
|
||||||
(if message (format out "<P>~a~%" message))))
|
(if message (format out "<P>~a~%" message)))))
|
||||||
|
|
||||||
(else (if html-ok? (generic-title))))
|
(else (if html-ok? (generic-title))))
|
||||||
|
|
||||||
(cond (html-ok?
|
(cond
|
||||||
;; Output extra stuff and close the <body> tag.
|
(html-ok?
|
||||||
(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
|
;; Output extra stuff and close the <body> tag.
|
||||||
(write-string "</BODY>\n" out)))
|
(for-each (lambda (x) (format out "<BR>~s~%" x)) extras)
|
||||||
|
(write-string "</BODY>\n" out)))
|
||||||
; (force-output out) ;;; TODO check this
|
; (force-output out) ;;; TODO check this
|
||||||
; (flush-all-ports)
|
; (flush-all-ports)
|
||||||
(force-output out)
|
(force-output out)
|
||||||
|
|
|
@ -200,24 +200,26 @@
|
||||||
(define (file-serve-or-dir fname file-path req directory-serve)
|
(define (file-serve-or-dir fname file-path req directory-serve)
|
||||||
(if (file-name-directory? fname) ; Simple index generation.
|
(if (file-name-directory? fname) ; Simple index generation.
|
||||||
(directory-serve fname file-path req)
|
(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))
|
||||||
|
"/")))
|
||||||
|
|
||||||
(switch string=? (request:method req)
|
(else (http-error http-reply/forbidden req)))))
|
||||||
(("GET" "HEAD") ; Absolutely.
|
|
||||||
(let ((info (stat-carefully fname req)))
|
(else (http-error http-reply/method-not-allowed 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)
|
(define (directory-index-serve fname file-path req)
|
||||||
(file-serve (string-append fname "index.html") file-path req))
|
(file-serve (string-append fname "index.html") file-path req))
|
||||||
|
@ -261,17 +263,32 @@
|
||||||
(else "unknown.xbm")))
|
(else "unknown.xbm")))
|
||||||
|
|
||||||
(define (file-extension->tag fname)
|
(define (file-extension->tag fname)
|
||||||
(switch string-ci=? (file-name-extension fname)
|
(let ((ext (file-name-extension fname)))
|
||||||
((".txt") 'text)
|
(cond
|
||||||
((".doc" ".html" ".rtf" ".tex") 'doc)
|
((string-ci=? ext ".txt") 'text)
|
||||||
((".gif" ".jpg" ".jpeg" ".tiff" ".tif") 'image)
|
((or (string-ci=? ext ".doc")
|
||||||
((".mpeg" ".mpg") 'movie)
|
(string-ci=? ext ".html")
|
||||||
((".au" ".snd" ".wav") 'audio)
|
(string-ci=? ext ".rtf")
|
||||||
((".tar" ".zip" ".zoo") 'archive)
|
(string-ci=? ext ".tex")) 'doc)
|
||||||
((".gz" ".Z" ".z") 'compressed)
|
((or (string-ci=? ext ".gif")
|
||||||
((".uu") 'uu)
|
(string-ci=? ext ".jpg")
|
||||||
((".hqx") 'binhex)
|
(string-ci=? ext ".jpeg")
|
||||||
(else 'binary)))
|
(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)
|
(define (file-tag fname type)
|
||||||
(case type
|
(case type
|
||||||
|
@ -394,44 +411,49 @@
|
||||||
(string-append icon-name (tag->icon tag))))
|
(string-append icon-name (tag->icon tag))))
|
||||||
(else tag->icon))))
|
(else tag->icon))))
|
||||||
(lambda (fname file-path req)
|
(lambda (fname file-path req)
|
||||||
(switch string=? (request:method req)
|
(let ((request-method (request:method req)))
|
||||||
(("GET" "HEAD")
|
(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")))
|
||||||
|
|
||||||
(unless (eq? 'directory (file-info:type (stat-carefully fname req)))
|
(with-tag #t html ()
|
||||||
(http-error http-reply/forbidden req))
|
(let ((title (string-append "Index of /"
|
||||||
|
(join-strings file-path "/"))))
|
||||||
(unless (v0.9-request? req)
|
(with-tag #t head ()
|
||||||
(begin-http-header #t http-reply/ok)
|
(emit-title #t title))
|
||||||
(write-string "Content-type: text/html\r\n")
|
(with-tag #t body ()
|
||||||
(write-string "\r\n"))
|
(emit-header #t 1 title)
|
||||||
|
(with-tag #t pre ()
|
||||||
(with-tag #t html ()
|
(emit-tag #t 'img
|
||||||
(let ((title (string-append "Index of /"
|
(cons 'src (icon-name 'blank))
|
||||||
(join-strings file-path "/"))))
|
(cons 'alt " "))
|
||||||
(with-tag #t head ()
|
(write-string "Name ")
|
||||||
(emit-title #t title))
|
(write-string "Last modified ")
|
||||||
(with-tag #t body ()
|
(write-string "Size ")
|
||||||
(emit-header #t 1 title)
|
(write-string "Description")
|
||||||
(with-tag #t pre ()
|
(emit-tag #t 'hr)
|
||||||
(emit-tag #t 'img
|
(emit-tag #t 'img
|
||||||
(cons 'src (icon-name 'blank))
|
(cons 'src (icon-name 'back))
|
||||||
(cons 'alt " "))
|
(cons 'alt "[UP ]"))
|
||||||
(write-string "Name ")
|
(if (not (null? file-path))
|
||||||
(write-string "Last modified ")
|
(begin
|
||||||
(write-string "Size ")
|
(with-tag #t a ((href ".."))
|
||||||
(write-string "Description")
|
(write-string "Parent directory"))
|
||||||
(emit-tag #t 'hr)
|
(newline)))
|
||||||
(emit-tag #t 'img
|
|
||||||
(cons 'src (icon-name 'back))
|
|
||||||
(cons 'alt "[UP ]"))
|
|
||||||
(unless (null? file-path)
|
|
||||||
(with-tag #t a ((href ".."))
|
|
||||||
(write-string "Parent directory"))
|
|
||||||
(newline))
|
|
||||||
(let ((n-files (directory-index req fname icon-name)))
|
(let ((n-files (directory-index req fname icon-name)))
|
||||||
(emit-tag #t 'hr)
|
(emit-tag #t 'hr)
|
||||||
(format #t "~d files" n-files)))))))
|
(format #t "~d files" n-files)))))))
|
||||||
(else (http-error http-reply/method-not-allowed req))))))
|
(else (http-error http-reply/method-not-allowed req)))))))
|
||||||
|
|
||||||
(define (index-or-directory-server icon-name)
|
(define (index-or-directory-server icon-name)
|
||||||
(let ((directory-serve (directory-server icon-name)))
|
(let ((directory-serve (directory-server icon-name)))
|
||||||
|
@ -467,18 +489,21 @@
|
||||||
(call-with-input-file filename
|
(call-with-input-file filename
|
||||||
(lambda (in)
|
(lambda (in)
|
||||||
(let ((out (current-output-port)))
|
(let ((out (current-output-port)))
|
||||||
(unless (v0.9-request? req)
|
(if (not (v0.9-request? req))
|
||||||
(begin-http-header out http-reply/ok)
|
(begin
|
||||||
(receive (filename content-encoding)
|
(begin-http-header out http-reply/ok)
|
||||||
(file-extension->content-encoding filename)
|
(receive (filename content-encoding)
|
||||||
(if content-encoding
|
(file-extension->content-encoding filename)
|
||||||
(format out "Content-encoding: ~A\r~%" content-encoding))
|
(if content-encoding
|
||||||
(? ((file-extension->content-type filename) =>
|
(format out "Content-encoding: ~A\r~%"
|
||||||
(lambda (ct) (format out "Content-type: ~A\r~%" ct)))))
|
content-encoding))
|
||||||
(format out "Last-modified: ~A\r~%"
|
(cond ((file-extension->content-type filename) =>
|
||||||
(time->http-date-string (file-info:mtime info)))
|
(lambda (ct)
|
||||||
(format out "Content-length: ~D\r~%" (file-info:size info))
|
(format out "Content-type: ~A\r~%" ct)))))
|
||||||
(write-string "\r\n" out))
|
(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))))))
|
(copy-inport->outport in out))))))
|
||||||
|
|
||||||
|
|
||||||
|
@ -497,31 +522,38 @@
|
||||||
|
|
||||||
|
|
||||||
(define (file-extension->content-type fname)
|
(define (file-extension->content-type fname)
|
||||||
(switch string-ci=? (file-name-extension fname)
|
(let ((ext (file-name-extension fname)))
|
||||||
((".html") "text/html")
|
(cond
|
||||||
((".txt") "text/plain")
|
((string-ci=? ext ".html") "text/html")
|
||||||
((".gif") "image/gif")
|
((string-ci=? ext ".txt") "text/plain")
|
||||||
((".png") "image/png")
|
((string-ci=? ext ".gif") "image/gif")
|
||||||
((".jpg" ".jpeg") "image/jpeg")
|
((string-ci=? ext ".png") "image/png")
|
||||||
((".tiff" ".tif") "image/tif")
|
((or (string-ci=? ext ".jpg")
|
||||||
((".rtf") "text/rtf")
|
(string-ci=? ext ".jpeg")) "image/jpeg")
|
||||||
((".mpeg" ".mpg") "video/mpeg")
|
((or (string-ci=? ext ".tiff")
|
||||||
((".au" ".snd") "audio/basic")
|
(string-ci=? ext ".tif")) "image/tif")
|
||||||
((".wav") "audio/x-wav")
|
((string-ci=? ext ".rtf") "text/rtf")
|
||||||
((".dvi") "application/x-dvi")
|
((or (string-ci=? ext ".mpeg")
|
||||||
((".tex" ".latex") "application/latex")
|
(string-ci=? ext ".mpg")) "video/mpeg")
|
||||||
((".zip") "application/zip")
|
((or (string-ci=? ext ".au")
|
||||||
((".tar") "application/tar")
|
(string-ci=? ext ".snd")) "audio/basic")
|
||||||
((".ps") "application/postscript")
|
((string-ci=? ext ".wav") "audio/x-wav")
|
||||||
((".pdf") "application/pdf")
|
((string-ci=? ext ".dvi") "application/x-dvi")
|
||||||
(else "application/octet-stream")))
|
((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)
|
(define (file-extension->content-encoding fname)
|
||||||
(cond
|
(cond
|
||||||
((switch string-ci=? (file-name-extension fname)
|
((let ((ext (file-name-extension fname)))
|
||||||
((".Z") "x-compress")
|
(cond
|
||||||
((".gz") "x-gzip")
|
((string-ci=? ext ".Z") "x-compress")
|
||||||
(else #f))
|
((string-ci=? ext ".gz") "x-gzip")
|
||||||
|
(else #f)))
|
||||||
=> (lambda (encoding)
|
=> (lambda (encoding)
|
||||||
(values (file-name-sans-extension fname) encoding)))
|
(values (file-name-sans-extension fname) encoding)))
|
||||||
(else (values fname #f))))
|
(else (values fname #f))))
|
||||||
|
@ -531,7 +563,7 @@
|
||||||
(define (copy-inport->outport in out)
|
(define (copy-inport->outport in out)
|
||||||
(let ((buf (make-string server/buffer-size)))
|
(let ((buf (make-string server/buffer-size)))
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(? ((read-string! buf in) => (lambda (nchars)
|
(cond ((read-string! buf in) => (lambda (nchars)
|
||||||
(write-string buf out 0 nchars)
|
(write-string buf out 0 nchars)
|
||||||
(loop))))))
|
(loop))))))
|
||||||
(force-output out))
|
(force-output out))
|
||||||
|
|
|
@ -129,35 +129,36 @@
|
||||||
(string-append "info?" node-name))))))
|
(string-append "info?" node-name))))))
|
||||||
|
|
||||||
(lambda (path req)
|
(lambda (path req)
|
||||||
(switch string=? (request:method req)
|
(let ((request-method (request:method req)))
|
||||||
(("GET")
|
(cond
|
||||||
(with-fatal-error-handler
|
((string=? request-method "GET")
|
||||||
(lambda (c decline)
|
(with-fatal-error-handler
|
||||||
(cond
|
(lambda (c decline)
|
||||||
((info-gateway-error? c)
|
(cond
|
||||||
(apply http-error http-reply/internal-error req
|
((info-gateway-error? c)
|
||||||
(condition-stuff c)))
|
(apply http-error http-reply/internal-error req
|
||||||
((http-error? c)
|
(condition-stuff c)))
|
||||||
(apply http-error (car (condition-stuff c)) req
|
((http-error? c)
|
||||||
(cddr (condition-stuff c))))
|
(apply http-error (car (condition-stuff c)) req
|
||||||
(else
|
(cddr (condition-stuff c))))
|
||||||
(decline))))
|
(else
|
||||||
|
(decline))))
|
||||||
|
|
||||||
|
(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")))
|
||||||
|
|
||||||
|
(receive (find-entry node-name) (parse-info-url (request:url req))
|
||||||
|
(display-node node-name
|
||||||
|
(file-finder find-entry)
|
||||||
|
(referencer make-reference (request:url req))
|
||||||
|
icon-name))
|
||||||
|
|
||||||
(if (not (v0.9-request? req))
|
(with-tag #t address ()
|
||||||
(begin
|
(write-string address))))
|
||||||
(begin-http-header #t http-reply/ok)
|
(else (http-error http-reply/method-not-allowed req)))))))
|
||||||
(write-string "Content-type: text/html\r\n")
|
|
||||||
(write-string "\r\n")))
|
|
||||||
|
|
||||||
(receive (find-entry node-name) (parse-info-url (request:url req))
|
|
||||||
(display-node node-name
|
|
||||||
(file-finder find-entry)
|
|
||||||
(referencer make-reference (request:url req))
|
|
||||||
icon-name))
|
|
||||||
|
|
||||||
(with-tag #t address ()
|
|
||||||
(write-string address))))
|
|
||||||
(else (http-error http-reply/method-not-allowed req))))))
|
|
||||||
|
|
||||||
(define split-header-line
|
(define split-header-line
|
||||||
(let ((split (infix-splitter "(, *)|( +)|( *\t *)"))
|
(let ((split (infix-splitter "(, *)|( +)|( *\t *)"))
|
||||||
|
|
576
modules.scm
576
modules.scm
|
@ -1,25 +1,30 @@
|
||||||
;;; Scheme 48 module definitions for TCP/IP protocol suites.
|
;;; Scheme 48 module definitions for TCP/IP protocol suites.
|
||||||
;;; Copyright (c) 1995 by Olin Shivers.
|
;;; Copyright (c) 1995 by Olin Shivers.
|
||||||
|
|
||||||
|
(define-interface smtp-interface
|
||||||
|
(export sendmail %sendmail
|
||||||
|
expn vrfy mail-help
|
||||||
|
smtp-transactions
|
||||||
|
smtp-transactions/no-close
|
||||||
|
smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
|
||||||
|
smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
|
||||||
|
smtp/help smtp/noop smtp/quit smtp/turn
|
||||||
|
handle-smtp-reply
|
||||||
|
read-smtp-reply
|
||||||
|
parse-smtp-reply
|
||||||
|
smtp-stuff))
|
||||||
|
|
||||||
|
(define-interface smtp-internals-interface
|
||||||
|
(export read-crlf-line ; These two should be in an
|
||||||
|
write-crlf ; auxiliary module.
|
||||||
|
|
||||||
|
smtp-query
|
||||||
|
nullary-smtp-command
|
||||||
|
unary-smtp-command))
|
||||||
|
|
||||||
(define-structures
|
(define-structures
|
||||||
((smtp (export sendmail %sendmail
|
((smtp smtp-interface)
|
||||||
expn vrfy mail-help
|
(smtp-internals smtp-internals-interface))
|
||||||
smtp-transactions
|
|
||||||
smtp-transactions/no-close
|
|
||||||
smtp/open smtp/helo smtp/mail smtp/rcpt smtp/data
|
|
||||||
smtp/send smtp/soml smtp/saml smtp/rset smtp/expn
|
|
||||||
smtp/help smtp/noop smtp/quit smtp/turn
|
|
||||||
handle-smtp-reply
|
|
||||||
read-smtp-reply
|
|
||||||
parse-smtp-reply
|
|
||||||
smtp-stuff))
|
|
||||||
(smtp-internals (export read-crlf-line ; These two should be in an
|
|
||||||
write-crlf ; auxiliary module.
|
|
||||||
|
|
||||||
smtp-query
|
|
||||||
nullary-smtp-command
|
|
||||||
unary-smtp-command)))
|
|
||||||
|
|
||||||
|
|
||||||
(open scsh ; write-string read-string/partial force-output
|
(open scsh ; write-string read-string/partial force-output
|
||||||
; system-name user-login-name and sockets
|
; system-name user-login-name and sockets
|
||||||
|
@ -27,15 +32,16 @@
|
||||||
receiving ; values receive
|
receiving ; values receive
|
||||||
let-opt ; let-optionals
|
let-opt ; let-optionals
|
||||||
error-package ; error
|
error-package ; error
|
||||||
switch-syntax ; switchq
|
|
||||||
condhax ; ? for COND
|
|
||||||
scheme)
|
scheme)
|
||||||
(files smtp))
|
(files smtp))
|
||||||
|
|
||||||
|
|
||||||
(define-structure crlf-io (export read-crlf-line
|
(define-interface crlf-io-interface
|
||||||
read-crlf-line-timeout
|
(export read-crlf-line
|
||||||
write-crlf)
|
read-crlf-line-timeout
|
||||||
|
write-crlf))
|
||||||
|
|
||||||
|
(define-structure crlf-io crlf-io-interface
|
||||||
(open ascii ; ascii->char
|
(open ascii ; ascii->char
|
||||||
scsh ; read-line write-string force-output
|
scsh ; read-line write-string force-output
|
||||||
receiving ; MV return (RECEIVE and VALUES)
|
receiving ; MV return (RECEIVE and VALUES)
|
||||||
|
@ -45,26 +51,19 @@
|
||||||
(files crlf-io))
|
(files crlf-io))
|
||||||
|
|
||||||
|
|
||||||
(define-structures ((switch-syntax (export (switch :syntax)
|
(define-interface rfc822-interface
|
||||||
(switchq :syntax)))
|
(export read-rfc822-headers
|
||||||
(condhax (export (when :syntax)
|
read-rfc822-field
|
||||||
(unless :syntax)
|
%read-rfc822-headers
|
||||||
(? :syntax))))
|
%read-rfc822-field
|
||||||
(open scheme)
|
rejoin-header-lines
|
||||||
(files conditionals))
|
get-header-all
|
||||||
|
get-header-lines
|
||||||
|
get-header
|
||||||
|
))
|
||||||
|
|
||||||
|
(define-structure rfc822 rfc822-interface
|
||||||
(define-structure rfc822 (export read-rfc822-headers
|
|
||||||
read-rfc822-field
|
|
||||||
%read-rfc822-headers
|
|
||||||
%read-rfc822-field
|
|
||||||
rejoin-header-lines
|
|
||||||
get-header-all
|
|
||||||
get-header-lines
|
|
||||||
get-header
|
|
||||||
)
|
|
||||||
(open receiving ; MV return (RECEIVE and VALUES)
|
(open receiving ; MV return (RECEIVE and VALUES)
|
||||||
condhax ; ? for COND
|
|
||||||
scsh-utilities ; index
|
scsh-utilities ; index
|
||||||
string-lib
|
string-lib
|
||||||
let-opt ; let-optionals
|
let-opt ; let-optionals
|
||||||
|
@ -77,32 +76,39 @@
|
||||||
(files rfc822))
|
(files rfc822))
|
||||||
|
|
||||||
|
|
||||||
(define-structure strings (export string-map
|
(define-interface strings-interface
|
||||||
downcase-string
|
(export string-map
|
||||||
upcase-string
|
downcase-string
|
||||||
char-set-index
|
upcase-string
|
||||||
char-set-rindex
|
char-set-index
|
||||||
string-reduce
|
char-set-rindex
|
||||||
skip-whitespace
|
string-reduce
|
||||||
string-prefix?
|
skip-whitespace
|
||||||
string-suffix?
|
string-prefix?
|
||||||
trim-spaces)
|
string-suffix?
|
||||||
|
trim-spaces))
|
||||||
|
|
||||||
|
(define-structure strings strings-interface
|
||||||
(open char-set-lib let-opt scheme)
|
(open char-set-lib let-opt scheme)
|
||||||
(files stringhax))
|
(files stringhax))
|
||||||
|
|
||||||
(define-structure uri-package (export parse-uri
|
|
||||||
uri-escaped-chars
|
(define-interface uri-interface
|
||||||
unescape-uri
|
(export parse-uri
|
||||||
escape-uri
|
uri-escaped-chars
|
||||||
resolve-uri
|
unescape-uri
|
||||||
split-uri-path
|
escape-uri
|
||||||
uri-path-list->path
|
resolve-uri
|
||||||
simplify-uri-path)
|
split-uri-path
|
||||||
|
uri-path-list->path
|
||||||
|
simplify-uri-path))
|
||||||
|
|
||||||
|
(define-structure uri uri-interface
|
||||||
(open scsh-utilities
|
(open scsh-utilities
|
||||||
string-lib
|
string-lib
|
||||||
let-opt
|
let-opt
|
||||||
receiving
|
receiving
|
||||||
condhax
|
|
||||||
ascii
|
ascii
|
||||||
strings
|
strings
|
||||||
char-set-lib
|
char-set-lib
|
||||||
|
@ -111,136 +117,147 @@
|
||||||
scheme)
|
scheme)
|
||||||
(files uri))
|
(files uri))
|
||||||
|
|
||||||
(define-structure url-package (export userhost? ; USERHOST
|
|
||||||
make-userhost ; record struct
|
|
||||||
|
|
||||||
userhost:user
|
(define-interface url-interface
|
||||||
userhost:password
|
(export userhost? ; USERHOST
|
||||||
userhost:host
|
make-userhost ; record struct
|
||||||
userhost:port
|
|
||||||
|
|
||||||
set-userhost:user
|
userhost:user
|
||||||
set-userhost:password
|
userhost:password
|
||||||
set-userhost:host
|
userhost:host
|
||||||
set-userhost:port
|
userhost:port
|
||||||
|
|
||||||
parse-userhost ; parse &
|
|
||||||
userhost->string ; unparse.
|
|
||||||
|
|
||||||
http-url? ; HTTP-URL
|
set-userhost:user
|
||||||
make-http-url ; record struct
|
set-userhost:password
|
||||||
|
set-userhost:host
|
||||||
|
set-userhost:port
|
||||||
|
|
||||||
|
parse-userhost ; parse &
|
||||||
|
userhost->string ; unparse.
|
||||||
|
|
||||||
http-url:userhost
|
http-url? ; HTTP-URL
|
||||||
http-url:path
|
make-http-url ; record struct
|
||||||
http-url:search
|
|
||||||
http-url:frag-id
|
|
||||||
|
|
||||||
set-http-url:userhost
|
http-url:userhost
|
||||||
set-http-url:path
|
http-url:path
|
||||||
set-http-url:search
|
http-url:search
|
||||||
set-http-url:frag-id
|
http-url:frag-id
|
||||||
|
|
||||||
parse-http-url ; parse &
|
|
||||||
http-url->string) ; unparse.
|
|
||||||
|
|
||||||
|
set-http-url:userhost
|
||||||
|
set-http-url:path
|
||||||
|
set-http-url:search
|
||||||
|
set-http-url:frag-id
|
||||||
|
|
||||||
|
parse-http-url ; parse &
|
||||||
|
http-url->string)) ; unparse.
|
||||||
|
|
||||||
|
(define-structure url url-interface
|
||||||
(open defrec-package
|
(open defrec-package
|
||||||
receiving
|
receiving
|
||||||
condhax
|
|
||||||
string-lib
|
string-lib
|
||||||
char-set-lib
|
char-set-lib
|
||||||
uri-package
|
uri
|
||||||
scsh-utilities
|
scsh-utilities
|
||||||
httpd-error
|
httpd-error
|
||||||
scheme)
|
scheme)
|
||||||
(files url))
|
(files url))
|
||||||
|
|
||||||
|
|
||||||
(define-structure httpd-error (export http-error?
|
(define-interface httpd-error-interface
|
||||||
http-error
|
(export http-error?
|
||||||
fatal-syntax-error?
|
http-error
|
||||||
fatal-syntax-error)
|
fatal-syntax-error?
|
||||||
|
fatal-syntax-error))
|
||||||
|
|
||||||
|
(define-structure httpd-error httpd-error-interface
|
||||||
(open conditions signals handle scheme)
|
(open conditions signals handle scheme)
|
||||||
(files httpd-error))
|
(files httpd-error))
|
||||||
|
|
||||||
(define-structure handle-fatal-error (export with-fatal-error-handler*
|
|
||||||
(with-fatal-error-handler :syntax))
|
(define-interface handle-fatal-error-interface
|
||||||
|
(export with-fatal-error-handler*
|
||||||
|
(with-fatal-error-handler :syntax)))
|
||||||
|
|
||||||
|
(define-structure handle-fatal-error handle-fatal-error-interface
|
||||||
(open scheme conditions handle)
|
(open scheme conditions handle)
|
||||||
(files handle-fatal-error))
|
(files handle-fatal-error))
|
||||||
|
|
||||||
(define-structure httpd-core (export server/version
|
|
||||||
server/protocol
|
|
||||||
server/admin
|
|
||||||
set-server/admin!
|
|
||||||
|
|
||||||
http-log
|
(define-interface httpd-core-interface
|
||||||
*http-log?*
|
(export server/version
|
||||||
*http-log-port*
|
server/protocol
|
||||||
|
server/admin
|
||||||
|
set-server/admin!
|
||||||
|
|
||||||
httpd
|
http-log
|
||||||
|
*http-log?*
|
||||||
|
*http-log-port*
|
||||||
|
|
||||||
make-request ; HTTP request
|
httpd
|
||||||
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<=
|
make-request ; HTTP request
|
||||||
v0.9-request?
|
request? ; record type.
|
||||||
version->string
|
request:method
|
||||||
|
request:uri
|
||||||
;; Integer reply codes
|
request:url
|
||||||
reply-code->text
|
request:version
|
||||||
http-reply/ok
|
request:headers
|
||||||
http-reply/created
|
request:socket
|
||||||
http-reply/accepted
|
set-request:method
|
||||||
http-reply/prov-info
|
set-request:uri
|
||||||
http-reply/no-content
|
set-request:url
|
||||||
http-reply/mult-choice
|
set-request:version
|
||||||
http-reply/moved-perm
|
set-request:headers
|
||||||
http-reply/moved-temp
|
set-request:socket
|
||||||
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
|
version< version<=
|
||||||
begin-http-header
|
v0.9-request?
|
||||||
set-http-header-beginner!
|
version->string
|
||||||
send-http-error-reply
|
|
||||||
|
;; 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
|
||||||
|
|
||||||
set-my-fqdn!
|
time->http-date-string
|
||||||
set-my-port!)
|
begin-http-header
|
||||||
|
send-http-error-reply
|
||||||
|
|
||||||
|
set-my-fqdn!
|
||||||
|
set-my-port!))
|
||||||
|
|
||||||
|
(define-structure httpd-core httpd-core-interface
|
||||||
(open threads
|
(open threads
|
||||||
scsh
|
scsh
|
||||||
receiving
|
receiving
|
||||||
let-opt
|
let-opt
|
||||||
crlf-io
|
crlf-io
|
||||||
rfc822
|
rfc822
|
||||||
switch-syntax
|
|
||||||
condhax
|
|
||||||
strings
|
strings
|
||||||
char-set-lib
|
char-set-lib
|
||||||
defrec-package
|
defrec-package
|
||||||
|
@ -250,39 +267,48 @@
|
||||||
defenum-package
|
defenum-package
|
||||||
httpd-error
|
httpd-error
|
||||||
handle-fatal-error
|
handle-fatal-error
|
||||||
uri-package
|
uri
|
||||||
url-package
|
url
|
||||||
formats
|
formats
|
||||||
scheme)
|
scheme)
|
||||||
(files httpd-core))
|
(files httpd-core))
|
||||||
|
|
||||||
|
|
||||||
;;; For parsing submissions from HTML forms.
|
;;; For parsing submissions from HTML forms.
|
||||||
(define-structure parse-html-forms (export parse-html-form-query unescape-uri+)
|
(define-interface parse-html-forms-interface
|
||||||
|
(export parse-html-form-query unescape-uri+))
|
||||||
|
|
||||||
|
(define-structure parse-html-forms parse-html-forms-interface
|
||||||
(open scsh scsh-utilities let-opt string-lib
|
(open scsh scsh-utilities let-opt string-lib
|
||||||
receiving uri-package strings condhax scheme)
|
receiving uri strings
|
||||||
|
|
||||||
|
scheme)
|
||||||
(files parse-forms))
|
(files parse-forms))
|
||||||
|
|
||||||
|
|
||||||
;;; For writing CGI scripts in Scheme.
|
;;; For writing CGI scripts in Scheme.
|
||||||
(define-structure cgi-script-package (export cgi-form-query)
|
(define-interface cgi-script-interface (export cgi-form-query))
|
||||||
|
|
||||||
|
(define-structure cgi-script cgi-script-interface
|
||||||
(open scsh
|
(open scsh
|
||||||
switch-syntax
|
|
||||||
error-package
|
error-package
|
||||||
parse-html-forms
|
parse-html-forms
|
||||||
scheme)
|
scheme)
|
||||||
(files cgi-script))
|
(files cgi-script))
|
||||||
|
|
||||||
;;; Provides the server interface to CGI scripts.
|
;;; Provides the server interface to CGI scripts.
|
||||||
(define-structure cgi-server-package (export cgi-default-bin-path
|
(define-interface cgi-server-interface
|
||||||
cgi-handler
|
(export cgi-default-bin-path
|
||||||
initialise-request-invariant-cgi-env)
|
cgi-handler
|
||||||
|
initialise-request-invariant-cgi-env))
|
||||||
|
|
||||||
|
(define-structure cgi-server cgi-server-interface
|
||||||
(open strings
|
(open strings
|
||||||
string-lib
|
string-lib
|
||||||
rfc822
|
rfc822
|
||||||
crlf-io ; WRITE-CRLF
|
crlf-io ; WRITE-CRLF
|
||||||
uri-package
|
uri
|
||||||
url-package ; HTTP-URL record type
|
url ; HTTP-URL record type
|
||||||
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes
|
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes
|
||||||
; version stuff
|
; version stuff
|
||||||
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
|
||||||
|
@ -290,63 +316,68 @@
|
||||||
scsh-utilities ; INDEX
|
scsh-utilities ; INDEX
|
||||||
scsh ; syscalls
|
scsh ; syscalls
|
||||||
formats ; format
|
formats ; format
|
||||||
condhax ; ? is COND
|
|
||||||
switch-syntax ; SWITCHQ
|
|
||||||
scheme)
|
scheme)
|
||||||
(files cgi-server))
|
(files cgi-server))
|
||||||
|
|
||||||
(define-structure htmlout-package (export emit-tag
|
|
||||||
emit-close-tag
|
|
||||||
|
|
||||||
emit-p
|
(define-interface htmlout-interface
|
||||||
emit-title
|
(export emit-tag
|
||||||
emit-header ; And so forth...
|
emit-close-tag
|
||||||
|
|
||||||
with-tag
|
emit-p
|
||||||
with-tag*
|
emit-title
|
||||||
|
emit-header ; And so forth...
|
||||||
|
|
||||||
escape-html
|
with-tag
|
||||||
emit-text)
|
with-tag*
|
||||||
|
|
||||||
|
escape-html
|
||||||
|
emit-text))
|
||||||
|
|
||||||
|
(define-structure htmlout htmlout-interface
|
||||||
(open scsh scsh-utilities strings formats ascii receiving scheme)
|
(open scsh scsh-utilities strings formats ascii receiving scheme)
|
||||||
(files htmlout))
|
(files htmlout))
|
||||||
|
|
||||||
(define-structure httpd-basic-handlers (export alist-path-dispatcher
|
|
||||||
home-dir-handler
|
(define-interface httpd-basic-handlers-interface
|
||||||
tilde-home-dir-handler
|
(export alist-path-dispatcher
|
||||||
rooted-file-handler
|
home-dir-handler
|
||||||
rooted-file-or-directory-handler
|
tilde-home-dir-handler
|
||||||
null-path-handler
|
rooted-file-handler
|
||||||
serve-rooted-file-path
|
rooted-file-or-directory-handler
|
||||||
file-serve
|
null-path-handler
|
||||||
file-server-and-dir
|
serve-rooted-file-path
|
||||||
http-homedir
|
file-serve
|
||||||
send-file
|
file-server-and-dir
|
||||||
dotdot-check
|
http-homedir
|
||||||
file-extension->content-type
|
send-file
|
||||||
copy-inport->outport)
|
dotdot-check
|
||||||
|
file-extension->content-type
|
||||||
|
copy-inport->outport))
|
||||||
|
|
||||||
|
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
||||||
(open scsh ; syscalls
|
(open scsh ; syscalls
|
||||||
formats ; FORMAT
|
formats ; FORMAT
|
||||||
condhax ; UNLESS, ? for COND
|
|
||||||
switch-syntax ; Conditionals
|
|
||||||
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
||||||
; v0.9-request, begin-http-header
|
; v0.9-request, begin-http-header
|
||||||
httpd-error
|
httpd-error
|
||||||
htmlout-package
|
htmlout
|
||||||
conditions ; CONDITION-STUFF
|
conditions ; CONDITION-STUFF
|
||||||
url-package ; HTTP-URL record type
|
url ; HTTP-URL record type
|
||||||
scheme)
|
scheme)
|
||||||
(files httpd-handlers))
|
(files httpd-handlers))
|
||||||
|
|
||||||
|
|
||||||
(define-structure seval-handler-package (export seval-handler)
|
(define-interface seval-handler-interface
|
||||||
|
(export seval-handler))
|
||||||
|
|
||||||
|
(define-structure seval-handler seval-handler-interface
|
||||||
(open scsh ; syscalls & INDEX
|
(open scsh ; syscalls & INDEX
|
||||||
condhax ; WHEN, ? for COND
|
|
||||||
switch-syntax ; Conditionals
|
|
||||||
httpd-error
|
httpd-error
|
||||||
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
|
||||||
; v0.9-request, reply formatting stuff.
|
; v0.9-request, reply formatting stuff.
|
||||||
uri-package ; UNESCAPE-URI
|
uri ; UNESCAPE-URI
|
||||||
htmlout-package ; Formatted HTML output
|
htmlout ; Formatted HTML output
|
||||||
error-package ; ERROR
|
error-package ; ERROR
|
||||||
pp ; Pretty-printer
|
pp ; Pretty-printer
|
||||||
strings rfc822
|
strings rfc822
|
||||||
|
@ -357,10 +388,14 @@
|
||||||
scheme)
|
scheme)
|
||||||
(files seval))
|
(files seval))
|
||||||
|
|
||||||
(define-structure httpd-access-control (export access-denier
|
|
||||||
access-allower
|
(define-interface httpd-access-control-interface
|
||||||
access-controller
|
(export access-denier
|
||||||
access-controlled-handler)
|
access-allower
|
||||||
|
access-controller
|
||||||
|
access-controlled-handler))
|
||||||
|
|
||||||
|
(define-structure httpd-access-control httpd-access-control-interface
|
||||||
(open big-scheme
|
(open big-scheme
|
||||||
strings
|
strings
|
||||||
httpd-core
|
httpd-core
|
||||||
|
@ -369,56 +404,68 @@
|
||||||
scheme)
|
scheme)
|
||||||
(files httpd-access-control))
|
(files httpd-access-control))
|
||||||
|
|
||||||
(define-structure info-gateway (export info-handler
|
|
||||||
find-info-file
|
(define-interface info-gateway-interface
|
||||||
info-gateway-error)
|
(export info-handler
|
||||||
|
find-info-file
|
||||||
|
info-gateway-error))
|
||||||
|
|
||||||
|
(define-structure info-gateway info-gateway-interface
|
||||||
(open big-scheme
|
(open big-scheme
|
||||||
string-lib
|
string-lib
|
||||||
conditions signals handle
|
conditions signals handle
|
||||||
switch-syntax
|
|
||||||
condhax
|
|
||||||
strings
|
strings
|
||||||
htmlout-package
|
htmlout
|
||||||
httpd-core
|
httpd-core
|
||||||
httpd-error
|
httpd-error
|
||||||
url-package
|
url
|
||||||
uri-package
|
uri
|
||||||
scsh
|
scsh
|
||||||
scheme)
|
scheme)
|
||||||
(files info-gateway))
|
(files info-gateway))
|
||||||
|
|
||||||
(define-structure rman-gateway (export rman-handler
|
|
||||||
man
|
(define-interface rman-gateway-interface
|
||||||
parse-man-entry
|
(export rman-handler
|
||||||
cat-man-page
|
man
|
||||||
find-man-file
|
parse-man-entry
|
||||||
file->man-directory
|
cat-man-page
|
||||||
cat-n-decode
|
find-man-file
|
||||||
nroff-n-decode)
|
file->man-directory
|
||||||
|
cat-n-decode
|
||||||
|
nroff-n-decode))
|
||||||
|
|
||||||
|
(define-structure rman-gateway rman-gateway-interface
|
||||||
(open httpd-core
|
(open httpd-core
|
||||||
httpd-error
|
httpd-error
|
||||||
conditions
|
conditions
|
||||||
url-package
|
url
|
||||||
uri-package
|
uri
|
||||||
htmlout-package
|
htmlout
|
||||||
httpd-basic-handlers
|
httpd-basic-handlers
|
||||||
switch-syntax
|
|
||||||
condhax
|
|
||||||
handle-fatal-error
|
handle-fatal-error
|
||||||
scsh
|
scsh
|
||||||
let-opt
|
let-opt
|
||||||
scheme)
|
scheme)
|
||||||
(files rman-gateway))
|
(files rman-gateway))
|
||||||
|
|
||||||
(define-structure ls (export ls
|
|
||||||
arguments->ls-flags)
|
(define-interface ls-interface
|
||||||
|
(export ls
|
||||||
|
arguments->ls-flags))
|
||||||
|
|
||||||
|
(define-structure ls ls-interface
|
||||||
(open scheme handle
|
(open scheme handle
|
||||||
big-scheme bitwise
|
big-scheme bitwise
|
||||||
scsh)
|
scsh)
|
||||||
(files ls))
|
(files ls))
|
||||||
|
|
||||||
(define-structure ftpd (export ftpd
|
|
||||||
ftpd-inetd)
|
(define-interface ftpd-interface
|
||||||
|
(export ftpd
|
||||||
|
ftpd-inetd))
|
||||||
|
|
||||||
|
(define-structure ftpd ftpd-interface
|
||||||
(open scheme
|
(open scheme
|
||||||
conditions handle signals
|
conditions handle signals
|
||||||
structure-refs
|
structure-refs
|
||||||
|
@ -432,3 +479,72 @@
|
||||||
crlf-io strings ls)
|
crlf-io strings ls)
|
||||||
(access big-scheme)
|
(access big-scheme)
|
||||||
(files ftpd))
|
(files ftpd))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Here is toothless.scm
|
||||||
|
;;; Shouldn't the definitions be in an extra file? Andreas.
|
||||||
|
|
||||||
|
;;; -*- Scheme -*-
|
||||||
|
;;; This file defines a Scheme 48 module that is R4RS without features that
|
||||||
|
;;; could examine or effect the file system. You can also use it
|
||||||
|
;;; as a model of how to execute code in other protected environments
|
||||||
|
;;; in S48.
|
||||||
|
;;;
|
||||||
|
;;; Copyright (c) 1995 by Olin Shivers.
|
||||||
|
|
||||||
|
(define-interface loser-interface (export loser))
|
||||||
|
|
||||||
|
(define-structure loser (export loser)
|
||||||
|
(open scheme error-package)
|
||||||
|
(begin (define (loser name)
|
||||||
|
(lambda x (error "Illegal call" name)))))
|
||||||
|
|
||||||
|
;;; The toothless structure is R4RS without the dangerous procedures.
|
||||||
|
|
||||||
|
(define-interface toothless-interface (interface-of scheme))
|
||||||
|
|
||||||
|
(define-structure toothless toothless-interface
|
||||||
|
(open scheme loser)
|
||||||
|
(begin
|
||||||
|
(define call-with-input-file (loser "call-with-input-file"))
|
||||||
|
(define call-with-output-file (loser "call-with-output-file"))
|
||||||
|
(define load (loser "load"))
|
||||||
|
(define open-input-file (loser "open-input-file"))
|
||||||
|
(define open-output-file (loser "open-output-file"))
|
||||||
|
(define transcript-on (loser "transcript-on"))
|
||||||
|
(define with-input-from-file (loser "with-input-from-file"))
|
||||||
|
(define with-input-to-file (loser "with-input-to-file"))
|
||||||
|
(define eval (loser "eval"))
|
||||||
|
(define interaction-environment (loser "interaction-environment"))
|
||||||
|
(define scheme-report-environment (loser "scheme-report-environment"))))
|
||||||
|
|
||||||
|
;;; (EVAL-SAFELEY exp)
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;;; Create a brand new package, import the TOOTHLESS structure, and
|
||||||
|
;;; evaluate EXP in it. When the evaluation is done, you throw away
|
||||||
|
;;; the environment, so EXP's side-effects don't persist from one
|
||||||
|
;;; EVAL-SAFELY call to the next. If EXP raises an error exception,
|
||||||
|
;;; we abort and return #f.
|
||||||
|
|
||||||
|
(define-interface toothless-eval-interface (export eval-safely))
|
||||||
|
|
||||||
|
(define-structure toothless-eval toothless-eval-interface
|
||||||
|
(open evaluation ; eval
|
||||||
|
package-commands-internal ; config-package, get-reflective-tower
|
||||||
|
packages ; structure-package, make-simple-package
|
||||||
|
environments ; environment-ref
|
||||||
|
handle ; ignore-errors
|
||||||
|
scheme)
|
||||||
|
(access toothless) ; Force it to be loaded.
|
||||||
|
(begin
|
||||||
|
|
||||||
|
(define toothless-struct (environment-ref (config-package) 'toothless))
|
||||||
|
(define toothless-package (structure-package toothless-struct))
|
||||||
|
|
||||||
|
(define (new-safe-package)
|
||||||
|
(make-simple-package (list toothless-struct) #t
|
||||||
|
(get-reflective-tower toothless-package) ; ???
|
||||||
|
'safe-env))
|
||||||
|
|
||||||
|
(define (eval-safely exp)
|
||||||
|
(ignore-errors (lambda () (eval exp (new-safe-package)))))))
|
||||||
|
|
47
rfc822.scm
47
rfc822.scm
|
@ -109,19 +109,20 @@
|
||||||
|
|
||||||
(values #f #f) ; Blank line or EOF terminates header text.
|
(values #f #f) ; Blank line or EOF terminates header text.
|
||||||
|
|
||||||
(? ((string-index line1 #\:) => ; Find the colon and
|
(cond
|
||||||
(lambda (colon) ; split out field name.
|
((string-index line1 #\:) => ; Find the colon and
|
||||||
(let ((name (string->symbol-pref (substring line1 0 colon))))
|
(lambda (colon) ; split out field name.
|
||||||
;; Read in continuation lines.
|
(let ((name (string->symbol-pref (substring line1 0 colon))))
|
||||||
(let lp ((lines (list (substring line1
|
;; Read in continuation lines.
|
||||||
(+ colon 1)
|
(let lp ((lines (list (substring line1
|
||||||
(string-length line1)))))
|
(+ colon 1)
|
||||||
(let ((c (peek-char port))) ; Could return EOF.
|
(string-length line1)))))
|
||||||
|
(let ((c (peek-char port))) ; Could return EOF.
|
||||||
;;; RFC822: continuous lines has to start with a space or a htab
|
;;; RFC822: continuous lines has to start with a space or a htab
|
||||||
(if (or (eqv? c #\space) (eqv? c htab))
|
(if (or (eqv? c #\space) (eqv? c htab))
|
||||||
(lp (cons (read-line port) lines))
|
(lp (cons (read-line port) lines))
|
||||||
(values name (reverse lines))))))))
|
(values name (reverse lines))))))))
|
||||||
(else (error "Illegal RFC 822 field syntax." line1)))))) ; No :
|
(else (error "Illegal RFC 822 field syntax." line1)))))) ; No :
|
||||||
|
|
||||||
|
|
||||||
;;; (read-rfc822-headers [port])
|
;;; (read-rfc822-headers [port])
|
||||||
|
@ -146,17 +147,17 @@
|
||||||
(define (%read-rfc822-headers read-line port)
|
(define (%read-rfc822-headers read-line port)
|
||||||
(let lp ((alist '()))
|
(let lp ((alist '()))
|
||||||
(receive (field val) (%read-rfc822-field read-line port)
|
(receive (field val) (%read-rfc822-field read-line port)
|
||||||
(? (field (? ((assq field alist) =>
|
(cond (field (cond ((assq field alist) =>
|
||||||
(lambda (entry)
|
(lambda (entry)
|
||||||
(set-cdr! entry (cons val (cdr entry)))
|
(set-cdr! entry (cons val (cdr entry)))
|
||||||
(lp alist)))
|
(lp alist)))
|
||||||
(else (lp (cons (list field val) alist)))))
|
(else (lp (cons (list field val) alist)))))
|
||||||
|
|
||||||
;; We are done. Reverse the order of each entry and return.
|
;; We are done. Reverse the order of each entry and return.
|
||||||
(else (for-each (lambda (entry)
|
(else (for-each (lambda (entry)
|
||||||
(set-cdr! entry (reverse (cdr entry))))
|
(set-cdr! entry (reverse (cdr entry))))
|
||||||
alist)
|
alist)
|
||||||
alist)))))
|
alist)))))
|
||||||
|
|
||||||
;;; (rejoin-header-lines alist [separator])
|
;;; (rejoin-header-lines alist [separator])
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
|
@ -33,29 +33,30 @@
|
||||||
(man (:optional maybe-man man)))
|
(man (:optional maybe-man man)))
|
||||||
|
|
||||||
(lambda (path req)
|
(lambda (path req)
|
||||||
(switch string=? (request:method req)
|
(let ((request-method (request:method req)))
|
||||||
(("GET")
|
(cond
|
||||||
(with-fatal-error-handler
|
((string=? request-method "GET")
|
||||||
(lambda (c decline)
|
(with-fatal-error-handler
|
||||||
(cond
|
(lambda (c decline)
|
||||||
((http-error? c)
|
(cond
|
||||||
(apply http-error (car (condition-stuff c)) req
|
((http-error? c)
|
||||||
(cddr (condition-stuff c))))
|
(apply http-error (car (condition-stuff c)) req
|
||||||
(else
|
(cddr (condition-stuff c))))
|
||||||
(decline))))
|
(else
|
||||||
|
(decline))))
|
||||||
|
|
||||||
(if (not (v0.9-request? req))
|
(if (not (v0.9-request? req))
|
||||||
(begin
|
(begin
|
||||||
(begin-http-header #t http-reply/ok)
|
(begin-http-header #t http-reply/ok)
|
||||||
(write-string "Content-type: text/html\r\n")
|
(write-string "Content-type: text/html\r\n")
|
||||||
(write-string "\r\n")))
|
(write-string "\r\n")))
|
||||||
|
|
||||||
(receive (man-path entry and-then) (parse-man-url (request:url req))
|
(receive (man-path entry and-then) (parse-man-url (request:url req))
|
||||||
(emit-man-page entry man man-path and-then reference-template))
|
(emit-man-page entry man man-path and-then reference-template))
|
||||||
|
|
||||||
(with-tag #t address ()
|
(with-tag #t address ()
|
||||||
(display address))))
|
(display address))))
|
||||||
(else (http-error http-reply/method-not-allowed req))))))
|
(else (http-error http-reply/method-not-allowed req)))))))
|
||||||
|
|
||||||
(define (cat-man-page key section)
|
(define (cat-man-page key section)
|
||||||
(let ((title (if section
|
(let ((title (if section
|
||||||
|
|
|
@ -17,10 +17,11 @@
|
||||||
(http-log " Argumente : ~s~%" arglist)
|
(http-log " Argumente : ~s~%" arglist)
|
||||||
(http-log "----------------------------------------~%")
|
(http-log "----------------------------------------~%")
|
||||||
|
|
||||||
(switch string=? (request:method req)
|
(let ((request-method (request:method req)))
|
||||||
(("GET" "POST") ; Could do others also.
|
(if (or (string=? request-method "GET")
|
||||||
(wait (fork doit)))
|
(string=? request-method "POST")) ; Could do others also.
|
||||||
(else (http-error http-reply/method-not-allowed req)))))
|
(wait (fork doit))
|
||||||
|
(http-error http-reply/method-not-allowed req))))
|
||||||
|
|
||||||
(http-error http-reply/bad-request req "Error "))))
|
(http-error http-reply/bad-request req "Error "))))
|
||||||
|
|
||||||
|
@ -32,9 +33,9 @@
|
||||||
|
|
||||||
(define (split-and-decode-search-spec s)
|
(define (split-and-decode-search-spec s)
|
||||||
(let recur ((i 0))
|
(let recur ((i 0))
|
||||||
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
(cond ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||||
(recur (+ j 1)))))
|
(recur (+ j 1)))))
|
||||||
(else (list (unescape-uri s i (string-length s)))))))
|
(else (list (unescape-uri s i (string-length s)))))))
|
||||||
|
|
||||||
(define url-path)
|
(define url-path)
|
||||||
(define script-path)
|
(define script-path)
|
||||||
|
|
94
seval.scm
94
seval.scm
|
@ -52,37 +52,40 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (seval-handler path req)
|
(define (seval-handler path req)
|
||||||
(switch string=? (request:method req)
|
(let ((request-method (request:method req)))
|
||||||
(("POST") ; Could do others also.
|
(cond
|
||||||
|
((string=? request-method "POST") ; Could do others also.
|
||||||
|
|
||||||
(let ((modern-protocol? (not (v0.9-request? req))))
|
(let ((modern-protocol? (not (v0.9-request? req))))
|
||||||
(when modern-protocol?
|
(if modern-protocol?
|
||||||
(begin-http-header #t 200)
|
(begin
|
||||||
(write-string "Content-type: text/html\r\n\r\n"))
|
(begin-http-header #t 200)
|
||||||
(with-tag #t HEAD ()
|
(write-string "Content-type: text/html\r\n\r\n")))
|
||||||
(newline)
|
(with-tag #t HEAD ()
|
||||||
(emit-title #t "Scheme program output"))
|
(newline)
|
||||||
(newline))
|
(emit-title #t "Scheme program output"))
|
||||||
|
(newline))
|
||||||
|
|
||||||
|
(with-tag #t BODY ()
|
||||||
|
(newline)
|
||||||
|
(let ((sexp (read-request-sexp req)))
|
||||||
|
(do/timeout
|
||||||
|
10
|
||||||
|
(receive vals
|
||||||
|
;; Do the computation.
|
||||||
|
(begin (emit-header #t 2 "Output from execution")
|
||||||
|
(newline)
|
||||||
|
(with-tag #t PRE ()
|
||||||
|
(newline)
|
||||||
|
(force-output) ; In case we're gunned down.
|
||||||
|
(eval-safely sexp)))
|
||||||
|
|
||||||
|
;; Pretty-print the returned value(s).
|
||||||
|
(emit-header #t 2 "Return value(s)")
|
||||||
|
(with-tag #t PRE ()
|
||||||
|
(for-each p vals)))))))
|
||||||
|
|
||||||
(with-tag #t BODY ()
|
(else (http-error http-reply/method-not-allowed #f req)))))
|
||||||
(newline)
|
|
||||||
(let ((sexp (read-request-sexp req)))
|
|
||||||
(do/timeout 10
|
|
||||||
(receive vals
|
|
||||||
;; Do the computation.
|
|
||||||
(begin (emit-header #t 2 "Output from execution")
|
|
||||||
(newline)
|
|
||||||
(with-tag #t PRE ()
|
|
||||||
(newline)
|
|
||||||
(force-output) ; In case we're gunned down.
|
|
||||||
(eval-safely sexp)))
|
|
||||||
|
|
||||||
;; Pretty-print the returned value(s).
|
|
||||||
(emit-header #t 2 "Return value(s)")
|
|
||||||
(with-tag #t PRE ()
|
|
||||||
(for-each p vals)))))))
|
|
||||||
|
|
||||||
(else (http-error http-reply/method-not-allowed #f req))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Read an HTTP request entity body from stdin. The Content-length:
|
;;; Read an HTTP request entity body from stdin. The Content-length:
|
||||||
|
@ -93,19 +96,20 @@
|
||||||
;;; and return it.
|
;;; and return it.
|
||||||
|
|
||||||
(define (read-request-sexp req)
|
(define (read-request-sexp req)
|
||||||
(? ((get-header (request:headers req) 'content-length) =>
|
(cond
|
||||||
(lambda (cl-str) ; Take the first Content-length: header,
|
((get-header (request:headers req) 'content-length) =>
|
||||||
(let* ((cl-start (skip-whitespace cl-str)) ; skip whitespace,
|
(lambda (cl-str) ; Take the first Content-length: header,
|
||||||
(cl (if cl-start ; & convert to
|
(let* ((cl-start (skip-whitespace cl-str)) ; skip whitespace,
|
||||||
(string->number (substring cl-str ; a number.
|
(cl (if cl-start ; & convert to
|
||||||
cl-start
|
(string->number (substring cl-str ; a number.
|
||||||
(string-length cl-str)))
|
cl-start
|
||||||
0)) ; All whitespace?? -- WTF.
|
(string-length cl-str)))
|
||||||
(qs (read-string cl)) ; Read in CL chars,
|
0)) ; All whitespace?? -- WTF.
|
||||||
(q (parse-html-form-query qs)) ; and parse them up.
|
(qs (read-string cl)) ; Read in CL chars,
|
||||||
(s (? ((assoc "program" q) => cdr)
|
(q (parse-html-form-query qs)) ; and parse them up.
|
||||||
(else (error "No program in entity body.")))))
|
(s (cond ((assoc "program" q) => cdr)
|
||||||
(http-log "Seval sexp:~%~s~%" s)
|
(else (error "No program in entity body.")))))
|
||||||
(read (make-string-input-port s)))))
|
(http-log "Seval sexp:~%~s~%" s)
|
||||||
(else (http-error http-reply/bad-request req
|
(read (make-string-input-port s)))))
|
||||||
"No Content-length: field in POST request."))))
|
(else (http-error http-reply/bad-request req
|
||||||
|
"No Content-length: field in POST request."))))
|
||||||
|
|
46
smtp.scm
46
smtp.scm
|
@ -90,8 +90,8 @@
|
||||||
(define (filter-map f lis)
|
(define (filter-map f lis)
|
||||||
(let lp ((ans '()) (lis lis))
|
(let lp ((ans '()) (lis lis))
|
||||||
(if (pair? lis)
|
(if (pair? lis)
|
||||||
(lp (? ((f (car lis)) => (lambda (val) (cons val ans)))
|
(lp (cond ((f (car lis)) => (lambda (val) (cons val ans)))
|
||||||
(else ans))
|
(else ans))
|
||||||
(cdr lis))
|
(cdr lis))
|
||||||
(reverse ans))))
|
(reverse ans))))
|
||||||
|
|
||||||
|
@ -269,20 +269,20 @@
|
||||||
;; We got a positive acknowledgement for the DATA msg,
|
;; We got a positive acknowledgement for the DATA msg,
|
||||||
;; now send the message body.
|
;; now send the message body.
|
||||||
(let ((p (socket:outport socket)))
|
(let ((p (socket:outport socket)))
|
||||||
(? ((string? message)
|
(cond ((string? message)
|
||||||
(receive (data last-char) (smtp-stuff message #f)
|
(receive (data last-char) (smtp-stuff message #f)
|
||||||
(write-string data p)))
|
(write-string data p)))
|
||||||
|
|
||||||
((input-port? message)
|
((input-port? message)
|
||||||
(let lp ((last-char #f))
|
(let lp ((last-char #f))
|
||||||
(? ((read-string/partial 1024 message) =>
|
(cond ((read-string/partial 1024 message) =>
|
||||||
(lambda (chunk)
|
(lambda (chunk)
|
||||||
(receive (data last-char)
|
(receive (data last-char)
|
||||||
(smtp-stuff chunk last-char)
|
(smtp-stuff chunk last-char)
|
||||||
(write-string data p)
|
(write-string data p)
|
||||||
(lp last-char)))))))
|
(lp last-char)))))))
|
||||||
|
|
||||||
(else (error "Message must be string or input-port.")))
|
(else (error "Message must be string or input-port.")))
|
||||||
|
|
||||||
(write-string "\r\n.\r\n" p)
|
(write-string "\r\n.\r\n" p)
|
||||||
(force-output p)
|
(force-output p)
|
||||||
|
@ -320,7 +320,7 @@
|
||||||
(let ((quit (nullary-smtp-command "QUIT")))
|
(let ((quit (nullary-smtp-command "QUIT")))
|
||||||
(lambda (socket)
|
(lambda (socket)
|
||||||
(receive (code text) (quit socket) ; Quit & close socket gracefully.
|
(receive (code text) (quit socket) ; Quit & close socket gracefully.
|
||||||
(switchq = code
|
(case code
|
||||||
((221 421))
|
((221 421))
|
||||||
(else (close-socket socket))) ; But close in any event.
|
(else (close-socket socket))) ; But close in any event.
|
||||||
(values code text)))))
|
(values code text)))))
|
||||||
|
@ -339,7 +339,7 @@
|
||||||
|
|
||||||
(define (handle-smtp-reply socket)
|
(define (handle-smtp-reply socket)
|
||||||
(receive (code text) (read-smtp-reply (socket:inport socket))
|
(receive (code text) (read-smtp-reply (socket:inport socket))
|
||||||
(switchq = code
|
(case code
|
||||||
((221 421) (close-socket socket))) ; All done.
|
((221 421) (close-socket socket))) ; All done.
|
||||||
(values code text)))
|
(values code text)))
|
||||||
|
|
||||||
|
@ -423,12 +423,12 @@
|
||||||
(if (< i slen)
|
(if (< i slen)
|
||||||
(let ((c (string-ref s i)))
|
(let ((c (string-ref s i)))
|
||||||
(string-set! ns j c)
|
(string-set! ns j c)
|
||||||
(? ((and nl? (char=? c #\.))
|
(cond ((and nl? (char=? c #\.))
|
||||||
(string-set! ns (+ j 1) #\.)
|
(string-set! ns (+ j 1) #\.)
|
||||||
(lp #f (+ i 1) (+ j 2)))
|
(lp #f (+ i 1) (+ j 2)))
|
||||||
(else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
|
(else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
|
||||||
ns))
|
ns))
|
||||||
|
|
||||||
(if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR
|
(if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR
|
||||||
|
|
||||||
;;; Reply codes
|
;;; Reply codes
|
||||||
|
|
80
uri.scm
80
uri.scm
|
@ -110,16 +110,17 @@
|
||||||
|
|
||||||
(let lp ((i start) (j 0)) ; sweap over the string
|
(let lp ((i start) (j 0)) ; sweap over the string
|
||||||
(if (< j nlen)
|
(if (< j nlen)
|
||||||
(lp (? ((esc-seq? i) ; unescape
|
(lp (cond
|
||||||
|
((esc-seq? i) ; unescape
|
||||||
; escape-sequence
|
; escape-sequence
|
||||||
(string-set! ns j
|
(string-set! ns j
|
||||||
(let ((d1 (string-ref s (+ i 1)))
|
(let ((d1 (string-ref s (+ i 1)))
|
||||||
(d2 (string-ref s (+ i 2))))
|
(d2 (string-ref s (+ i 2))))
|
||||||
(ascii->char (+ (* 16 (hexchar->int d1))
|
(ascii->char (+ (* 16 (hexchar->int d1))
|
||||||
(hexchar->int d2)))))
|
(hexchar->int d2)))))
|
||||||
(+ i 3))
|
(+ i 3))
|
||||||
(else (string-set! ns j (string-ref s i))
|
(else (string-set! ns j (string-ref s i))
|
||||||
(+ i 1)))
|
(+ i 1)))
|
||||||
(+ j 1))))
|
(+ j 1))))
|
||||||
ns)))))
|
ns)))))
|
||||||
|
|
||||||
|
@ -174,18 +175,19 @@
|
||||||
; character to escape with %ff where ff
|
; character to escape with %ff where ff
|
||||||
; is the ascii-code in hexadecimal
|
; is the ascii-code in hexadecimal
|
||||||
; notation
|
; notation
|
||||||
(+ i (? ((char-set-contains? escaped-chars c)
|
(+ i (cond
|
||||||
(string-set! ns i #\%)
|
((char-set-contains? escaped-chars c)
|
||||||
(let* ((d (char->ascii c))
|
(string-set! ns i #\%)
|
||||||
(dhi (bitwise-and (arithmetic-shift d -4) #xF))
|
(let* ((d (char->ascii c))
|
||||||
(dlo (bitwise-and d #xF)))
|
(dhi (bitwise-and (arithmetic-shift d -4) #xF))
|
||||||
(string-set! ns (+ i 1)
|
(dlo (bitwise-and d #xF)))
|
||||||
(int->hexchar dhi))
|
(string-set! ns (+ i 1)
|
||||||
(string-set! ns (+ i 2)
|
(int->hexchar dhi))
|
||||||
(int->hexchar dlo)))
|
(string-set! ns (+ i 2)
|
||||||
3)
|
(int->hexchar dlo)))
|
||||||
(else (string-set! ns i c)
|
3)
|
||||||
1))))
|
(else (string-set! ns i c)
|
||||||
|
1))))
|
||||||
s)
|
s)
|
||||||
ns)))))
|
ns)))))
|
||||||
|
|
||||||
|
@ -213,20 +215,21 @@
|
||||||
(rhead '()) ; CP prefix, reversed.
|
(rhead '()) ; CP prefix, reversed.
|
||||||
(j 0)) ; J counts sequential /
|
(j 0)) ; J counts sequential /
|
||||||
|
|
||||||
(? ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
|
(cond
|
||||||
(lp (cdr cp-tail)
|
((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
|
||||||
(cons (car cp-tail) rhead)
|
(lp (cdr cp-tail)
|
||||||
(+ j 0)))
|
(cons (car cp-tail) rhead)
|
||||||
|
(+ j 0)))
|
||||||
|
|
||||||
((= j numsl) ; Win
|
((= j numsl) ; Win
|
||||||
(values cscheme (simplify-uri-path (rev-append rhead p))))
|
(values cscheme (simplify-uri-path (rev-append rhead p))))
|
||||||
|
|
||||||
((pair? cp-tail) ; Keep looking.
|
((pair? cp-tail) ; Keep looking.
|
||||||
(lp (cdr cp-tail)
|
(lp (cdr cp-tail)
|
||||||
(cons (car cp-tail) rhead)
|
(cons (car cp-tail) rhead)
|
||||||
1))
|
1))
|
||||||
|
|
||||||
(else (values #f #f))))) ; Lose.
|
(else (values #f #f))))) ; Lose.
|
||||||
|
|
||||||
|
|
||||||
;; P doesn't begin with a slash.
|
;; P doesn't begin with a slash.
|
||||||
|
@ -245,12 +248,13 @@
|
||||||
|
|
||||||
(define (split-uri-path uri start end) ; Split at /'s (infix grammar).
|
(define (split-uri-path uri start end) ; Split at /'s (infix grammar).
|
||||||
(let split ((i start)) ; "" -> ("")
|
(let split ((i start)) ; "" -> ("")
|
||||||
(? ((>= i end) '(""))
|
(cond
|
||||||
((string-index uri #\/ i) =>
|
((>= i end) '(""))
|
||||||
(lambda (slash)
|
((string-index uri #\/ i) =>
|
||||||
(cons (substring uri i slash)
|
(lambda (slash)
|
||||||
(split (+ slash 1)))))
|
(cons (substring uri i slash)
|
||||||
(else (list (substring uri i end))))))
|
(split (+ slash 1)))))
|
||||||
|
(else (list (substring uri i end))))))
|
||||||
|
|
||||||
|
|
||||||
;;; The elements of PLIST must be escaped in case they contain slashes.
|
;;; The elements of PLIST must be escaped in case they contain slashes.
|
||||||
|
|
12
url.scm
12
url.scm
|
@ -144,9 +144,9 @@
|
||||||
(userhost->string (http-url:userhost url))
|
(userhost->string (http-url:userhost url))
|
||||||
"/"
|
"/"
|
||||||
(uri-path-list->path (map escape-uri (http-url:path url)))
|
(uri-path-list->path (map escape-uri (http-url:path url)))
|
||||||
(? ((http-url:search url) =>
|
(cond ((http-url:search url) =>
|
||||||
(lambda (s) (string-append "?" s)))
|
(lambda (s) (string-append "?" s)))
|
||||||
(else ""))
|
(else ""))
|
||||||
(? ((http-url:frag-id url) =>
|
(cond ((http-url:frag-id url) =>
|
||||||
(lambda (fi) (string-append "#" fi)))
|
(lambda (fi) (string-append "#" fi)))
|
||||||
(else ""))))
|
(else ""))))
|
||||||
|
|
Loading…
Reference in New Issue