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

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:
interp 2001-08-20 11:31:03 +00:00
parent a741498c59
commit 6c702e9a03
14 changed files with 798 additions and 619 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
cgi-script.scm
View File

@ -82,13 +82,14 @@
;;; This only works for GET and POST methods.
(define (cgi-form-query)
(switch string=? (getenv "REQUEST_METHOD")
(let ((request-method (getenv "REQUEST_METHOD")))
(cond
(("GET")
(parse-html-form-query (getenv "QUERY_STRING")))
((string=? request-method "GET")
(parse-html-form-query (getenv "QUERY_STRING")))
(("POST")
(let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
(parse-html-form-query (read-string nchars))))
((string=? request-method "POST")
(let ((nchars (string->number (getenv "CONTENT_LENGTH"))))
(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.

92
cgi-server.scm
View File

@ -112,22 +112,25 @@
filename)))))
(http-log "search: ~s, argv: ~s~%" search argv)
(switch string=? (request:method req)
(("GET" "POST") ; Could do others also.
(if nph?
(wait (fork doit))
(cgi-send-reply (run/port* doit) req)))
(else (http-error http-reply/method-not-allowed req))))
(let ((request-method (request:method req)))
(cond
((or (string=? request-method "GET")
(string=? request-method "POST")) ; Could do others also.
(if nph?
(wait (fork doit))
(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"))))
(define (split-and-decode-search-spec s)
(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)))))
(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
@ -190,26 +193,26 @@
,@request-invariant-cgi-env ; Stuff that never changes (see below).
,@(? ((http-url:search (request:url req)) =>
(lambda (srch) `(("QUERY_STRING" . ,srch))))
(else '()))
,@(cond ((http-url:search (request:url req)) =>
(lambda (srch) `(("QUERY_STRING" . ,srch))))
(else '()))
,@(? ((get-header headers 'content-type) =>
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
(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-type) =>
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
(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))))))
(define request-invariant-cgi-env #f)
@ -239,29 +242,32 @@
(ctype (get-header headers 'content-type)) ; The script headers
(loc (get-header headers 'location))
(stat (let ((stat-lines (get-header-lines headers 'status)))
(? ((not (pair? stat-lines)) ; No status header.
"200 The idiot CGI script left out the status line.")
((null? (cdr stat-lines)) ; One line status header.
(car stat-lines))
(else ; Vas ist das?
(http-error http-reply/internal-error req
"CGI script generated multi-line status header")))))
(cond
((not (pair? stat-lines)) ; No status header.
"200 The idiot CGI script left out the status line.")
((null? (cdr stat-lines)) ; One line status header.
(car stat-lines))
(else ; Vas ist das?
(http-error http-reply/internal-error req
"CGI script generated multi-line status header")))))
(out (current-output-port)))
(http-log "headers: ~s~%" headers)
;; Send the reply header back to the client
;; (unless it's a headerless HTTP 0.9 reply).
(unless (v0.9-request? req)
(format out "HTTP/1.0 ~a\r~%" stat)
(if ctype (format out "Content-type: ~a\r~%" ctype))
(if loc (format out "Location: ~a\r~%" loc))
(write-crlf out))
(if (not (v0.9-request? req))
(begin
(format out "HTTP/1.0 ~a\r~%" stat)
(if ctype (format out "Content-type: ~a\r~%" ctype))
(if loc (format out "Location: ~a\r~%" loc))
(write-crlf out)))
(http-log "request:method=~a~%" (request:method req))
;; Copy the reply body back to the client and close the script port
;; (unless it's a bodiless HEAD transaction).
(unless (string=? (request:method req) "HEAD")
(copy-inport->outport script-port out)
(close-input-port script-port))))
(if (not (string=? (request:method req) "HEAD"))
(begin
(copy-inport->outport script-port out)
(close-input-port script-port)))))

2
htmlout.scm
View File

@ -145,7 +145,7 @@
(cons (ascii->char 34) """)))
(define *html-entities*
(chars->char-set (map car *html-entity-alist*)))
(list->char-set (map car *html-entity-alist*)))
(define *html-entity-table*
(let ((v (make-vector 256 #f)))

106
httpd-core.scm
View File

@ -191,7 +191,7 @@
(fatal-syntax-error "EOF while parsing request.")
(let* ((elts (string->words line)) ; Split at white-space.
(version (switch = (length elts)
(version (case (length elts)
((2) '(0 . 9))
((3) (parse-http-version (caddr elts)))
(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?, 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,
;; and the first EXTRA is the older Location: field.
((http-reply/moved-temp http-reply/moved-perm)
(when new-protocol?
(format out "URI: ~A\r~%" message)
(format out "Location: ~A\r~%" (car extras)))
(when html-ok?
((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)))
message))))
((http-reply/bad-request)
(when html-ok?
((= 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))))
(if message (format out "<BR>~%Reason: ~A~%" message)))))
((http-reply/unauthorized)
((= reply-code http-reply/unauthorized)
(if new-protocol?
(format out "WWW-Authenticate: ~A\r~%\r~%" message)) ; Vas is das?
(when html-ok?
(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))))
(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)))))
((http-reply/forbidden)
(unless html-ok?
(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)
(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/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)
(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)
((= reply-code http-reply/internal-error)
(format (current-error-port) "ERROR: ~A~%" message)
(when html-ok?
(generic-title)
(format out "The server encountered an internal error or
(if html-ok?
(begin
(generic-title)
(format out "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.~%"
server/admin)
(if message (format out "<P>~%~a~%" message))))
server/admin)
(if message (format out "<P>~%~a~%" message)))))
((http-reply/not-implemented)
(when html-ok?
(generic-title)
(format out "This server does not currently implement
((= reply-code http-reply/not-implemented)
(if html-ok?
(begin
(generic-title)
(format out "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 out "<P>~a~%" message)))))
(else (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)))
(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)

230
httpd-handlers.scm
View File

@ -200,24 +200,26 @@
(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))
"/")))
(switch string=? (request:method req)
(("GET" "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)))))
(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))
@ -261,17 +263,32 @@
(else "unknown.xbm")))
(define (file-extension->tag fname)
(switch string-ci=? (file-name-extension fname)
((".txt") 'text)
((".doc" ".html" ".rtf" ".tex") 'doc)
((".gif" ".jpg" ".jpeg" ".tiff" ".tif") 'image)
((".mpeg" ".mpg") 'movie)
((".au" ".snd" ".wav") 'audio)
((".tar" ".zip" ".zoo") 'archive)
((".gz" ".Z" ".z") 'compressed)
((".uu") 'uu)
((".hqx") 'binhex)
(else 'binary)))
(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
@ -394,44 +411,49 @@
(string-append icon-name (tag->icon tag))))
(else tag->icon))))
(lambda (fname file-path req)
(switch string=? (request:method req)
(("GET" "HEAD")
(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")))
(unless (eq? 'directory (file-info:type (stat-carefully fname req)))
(http-error http-reply/forbidden req))
(unless (v0.9-request? req)
(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 /"
(join-strings 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 ]"))
(unless (null? file-path)
(with-tag #t a ((href ".."))
(write-string "Parent directory"))
(newline))
(with-tag #t html ()
(let ((title (string-append "Index of /"
(join-strings 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))))))
(else (http-error http-reply/method-not-allowed req)))))))
(define (index-or-directory-server icon-name)
(let ((directory-serve (directory-server icon-name)))
@ -467,18 +489,21 @@
(call-with-input-file filename
(lambda (in)
(let ((out (current-output-port)))
(unless (v0.9-request? req)
(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))
(? ((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))
(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))))))
@ -497,31 +522,38 @@
(define (file-extension->content-type fname)
(switch string-ci=? (file-name-extension fname)
((".html") "text/html")
((".txt") "text/plain")
((".gif") "image/gif")
((".png") "image/png")
((".jpg" ".jpeg") "image/jpeg")
((".tiff" ".tif") "image/tif")
((".rtf") "text/rtf")
((".mpeg" ".mpg") "video/mpeg")
((".au" ".snd") "audio/basic")
((".wav") "audio/x-wav")
((".dvi") "application/x-dvi")
((".tex" ".latex") "application/latex")
((".zip") "application/zip")
((".tar") "application/tar")
((".ps") "application/postscript")
((".pdf") "application/pdf")
(else "application/octet-stream")))
(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
((switch string-ci=? (file-name-extension fname)
((".Z") "x-compress")
((".gz") "x-gzip")
(else #f))
((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))))
@ -531,7 +563,7 @@
(define (copy-inport->outport in out)
(let ((buf (make-string server/buffer-size)))
(let loop ()
(? ((read-string! buf in) => (lambda (nchars)
(write-string buf out 0 nchars)
(loop))))))
(cond ((read-string! buf in) => (lambda (nchars)
(write-string buf out 0 nchars)
(loop))))))
(force-output out))

57
info-gateway.scm
View File

@ -129,35 +129,36 @@
(string-append "info?" node-name))))))
(lambda (path req)
(switch string=? (request:method req)
(("GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((info-gateway-error? c)
(apply http-error http-reply/internal-error req
(condition-stuff c)))
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(else
(decline))))
(let ((request-method (request:method req)))
(cond
((string=? request-method "GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((info-gateway-error? c)
(apply http-error http-reply/internal-error req
(condition-stuff c)))
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(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))
(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))
(with-tag #t address ()
(write-string address))))
(else (http-error http-reply/method-not-allowed req))))))
(with-tag #t address ()
(write-string address))))
(else (http-error http-reply/method-not-allowed req)))))))
(define split-header-line
(let ((split (infix-splitter "(, *)|( +)|( *\t *)"))

576
modules.scm
View File

@ -1,25 +1,30 @@
;;; Scheme 48 module definitions for TCP/IP protocol suites.
;;; 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
((smtp (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))
(smtp-internals (export read-crlf-line ; These two should be in an
write-crlf ; auxiliary module.
smtp-query
nullary-smtp-command
unary-smtp-command)))
((smtp smtp-interface)
(smtp-internals smtp-internals-interface))
(open scsh ; write-string read-string/partial force-output
; system-name user-login-name and sockets
@ -27,15 +32,16 @@
receiving ; values receive
let-opt ; let-optionals
error-package ; error
switch-syntax ; switchq
condhax ; ? for COND
scheme)
(files smtp))
(define-structure crlf-io (export read-crlf-line
read-crlf-line-timeout
write-crlf)
(define-interface crlf-io-interface
(export read-crlf-line
read-crlf-line-timeout
write-crlf))
(define-structure crlf-io crlf-io-interface
(open ascii ; ascii->char
scsh ; read-line write-string force-output
receiving ; MV return (RECEIVE and VALUES)
@ -45,26 +51,19 @@
(files crlf-io))
(define-structures ((switch-syntax (export (switch :syntax)
(switchq :syntax)))
(condhax (export (when :syntax)
(unless :syntax)
(? :syntax))))
(open scheme)
(files conditionals))
(define-interface rfc822-interface
(export read-rfc822-headers
read-rfc822-field
%read-rfc822-headers
%read-rfc822-field
rejoin-header-lines
get-header-all
get-header-lines
get-header
))
(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
)
(define-structure rfc822 rfc822-interface
(open receiving ; MV return (RECEIVE and VALUES)
condhax ; ? for COND
scsh-utilities ; index
string-lib
let-opt ; let-optionals
@ -77,32 +76,39 @@
(files rfc822))
(define-structure strings (export string-map
downcase-string
upcase-string
char-set-index
char-set-rindex
string-reduce
skip-whitespace
string-prefix?
string-suffix?
trim-spaces)
(define-interface strings-interface
(export string-map
downcase-string
upcase-string
char-set-index
char-set-rindex
string-reduce
skip-whitespace
string-prefix?
string-suffix?
trim-spaces))
(define-structure strings strings-interface
(open char-set-lib let-opt scheme)
(files stringhax))
(define-structure uri-package (export parse-uri
uri-escaped-chars
unescape-uri
escape-uri
resolve-uri
split-uri-path
uri-path-list->path
simplify-uri-path)
(define-interface uri-interface
(export parse-uri
uri-escaped-chars
unescape-uri
escape-uri
resolve-uri
split-uri-path
uri-path-list->path
simplify-uri-path))
(define-structure uri uri-interface
(open scsh-utilities
string-lib
let-opt
receiving
condhax
ascii
strings
char-set-lib
@ -111,136 +117,147 @@
scheme)
(files uri))
(define-structure url-package (export userhost? ; USERHOST
make-userhost ; record struct
userhost:user
userhost:password
userhost:host
userhost:port
(define-interface url-interface
(export userhost? ; USERHOST
make-userhost ; record struct
set-userhost:user
set-userhost:password
set-userhost:host
set-userhost:port
parse-userhost ; parse &
userhost->string ; unparse.
userhost:user
userhost:password
userhost:host
userhost:port
http-url? ; HTTP-URL
make-http-url ; record struct
set-userhost:user
set-userhost:password
set-userhost:host
set-userhost:port
parse-userhost ; parse &
userhost->string ; unparse.
http-url:userhost
http-url:path
http-url:search
http-url:frag-id
http-url? ; HTTP-URL
make-http-url ; record struct
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.
http-url:userhost
http-url:path
http-url:search
http-url:frag-id
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
receiving
condhax
string-lib
char-set-lib
uri-package
uri
scsh-utilities
httpd-error
scheme)
(files url))
(define-structure httpd-error (export http-error?
http-error
fatal-syntax-error?
fatal-syntax-error)
(define-interface httpd-error-interface
(export http-error?
http-error
fatal-syntax-error?
fatal-syntax-error))
(define-structure httpd-error httpd-error-interface
(open conditions signals handle scheme)
(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)
(files handle-fatal-error))
(define-structure httpd-core (export server/version
server/protocol
server/admin
set-server/admin!
http-log
*http-log?*
*http-log-port*
(define-interface httpd-core-interface
(export server/version
server/protocol
server/admin
set-server/admin!
httpd
http-log
*http-log?*
*http-log-port*
make-request ; HTTP request
request? ; record type.
request:method
request:uri
request:url
request:version
request:headers
request:socket
set-request:method
set-request:uri
set-request:url
set-request:version
set-request:headers
set-request:socket
httpd
version< version<=
v0.9-request?
version->string
;; Integer reply codes
reply-code->text
http-reply/ok
http-reply/created
http-reply/accepted
http-reply/prov-info
http-reply/no-content
http-reply/mult-choice
http-reply/moved-perm
http-reply/moved-temp
http-reply/method
http-reply/not-mod
http-reply/bad-request
http-reply/unauthorized
http-reply/payment-req
http-reply/forbidden
http-reply/not-found
http-reply/method-not-allowed
http-reply/none-acceptable
http-reply/proxy-auth-required
http-reply/timeout
http-reply/conflict
http-reply/gone
http-reply/internal-error
http-reply/not-implemented
http-reply/bad-gateway
http-reply/service-unavailable
http-reply/gateway-timeout
make-request ; HTTP request
request? ; record type.
request:method
request:uri
request:url
request:version
request:headers
request:socket
set-request:method
set-request:uri
set-request:url
set-request:version
set-request:headers
set-request:socket
time->http-date-string
begin-http-header
set-http-header-beginner!
send-http-error-reply
version< version<=
v0.9-request?
version->string
;; Integer reply codes
reply-code->text
http-reply/ok
http-reply/created
http-reply/accepted
http-reply/prov-info
http-reply/no-content
http-reply/mult-choice
http-reply/moved-perm
http-reply/moved-temp
http-reply/method
http-reply/not-mod
http-reply/bad-request
http-reply/unauthorized
http-reply/payment-req
http-reply/forbidden
http-reply/not-found
http-reply/method-not-allowed
http-reply/none-acceptable
http-reply/proxy-auth-required
http-reply/timeout
http-reply/conflict
http-reply/gone
http-reply/internal-error
http-reply/not-implemented
http-reply/bad-gateway
http-reply/service-unavailable
http-reply/gateway-timeout
set-my-fqdn!
set-my-port!)
time->http-date-string
begin-http-header
send-http-error-reply
set-my-fqdn!
set-my-port!))
(define-structure httpd-core httpd-core-interface
(open threads
scsh
receiving
let-opt
crlf-io
rfc822
switch-syntax
condhax
strings
char-set-lib
defrec-package
@ -250,39 +267,48 @@
defenum-package
httpd-error
handle-fatal-error
uri-package
url-package
uri
url
formats
scheme)
(files httpd-core))
;;; 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
receiving uri-package strings condhax scheme)
receiving uri strings
scheme)
(files parse-forms))
;;; 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
switch-syntax
error-package
parse-html-forms
scheme)
(files cgi-script))
;;; Provides the server interface to CGI scripts.
(define-structure cgi-server-package (export cgi-default-bin-path
cgi-handler
initialise-request-invariant-cgi-env)
(define-interface cgi-server-interface
(export cgi-default-bin-path
cgi-handler
initialise-request-invariant-cgi-env))
(define-structure cgi-server cgi-server-interface
(open strings
string-lib
rfc822
crlf-io ; WRITE-CRLF
uri-package
url-package ; HTTP-URL record type
uri
url ; HTTP-URL record type
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes
; version stuff
httpd-basic-handlers ; HTTP-HOMEDIR, SERVE-ROOTED-FILE-PATH
@ -290,63 +316,68 @@
scsh-utilities ; INDEX
scsh ; syscalls
formats ; format
condhax ; ? is COND
switch-syntax ; SWITCHQ
scheme)
(files cgi-server))
(define-structure htmlout-package (export emit-tag
emit-close-tag
emit-p
emit-title
emit-header ; And so forth...
(define-interface htmlout-interface
(export emit-tag
emit-close-tag
with-tag
with-tag*
emit-p
emit-title
emit-header ; And so forth...
escape-html
emit-text)
with-tag
with-tag*
escape-html
emit-text))
(define-structure htmlout htmlout-interface
(open scsh scsh-utilities strings formats ascii receiving scheme)
(files htmlout))
(define-structure httpd-basic-handlers (export alist-path-dispatcher
home-dir-handler
tilde-home-dir-handler
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)
(define-interface httpd-basic-handlers-interface
(export alist-path-dispatcher
home-dir-handler
tilde-home-dir-handler
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))
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
(open scsh ; syscalls
formats ; FORMAT
condhax ; UNLESS, ? for COND
switch-syntax ; Conditionals
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
; v0.9-request, begin-http-header
httpd-error
htmlout-package
htmlout
conditions ; CONDITION-STUFF
url-package ; HTTP-URL record type
url ; HTTP-URL record type
scheme)
(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
condhax ; WHEN, ? for COND
switch-syntax ; Conditionals
httpd-error
httpd-core ; REQUEST record type, HTTP-ERROR & reply codes,
; v0.9-request, reply formatting stuff.
uri-package ; UNESCAPE-URI
htmlout-package ; Formatted HTML output
uri ; UNESCAPE-URI
htmlout ; Formatted HTML output
error-package ; ERROR
pp ; Pretty-printer
strings rfc822
@ -357,10 +388,14 @@
scheme)
(files seval))
(define-structure httpd-access-control (export access-denier
access-allower
access-controller
access-controlled-handler)
(define-interface httpd-access-control-interface
(export access-denier
access-allower
access-controller
access-controlled-handler))
(define-structure httpd-access-control httpd-access-control-interface
(open big-scheme
strings
httpd-core
@ -369,56 +404,68 @@
scheme)
(files httpd-access-control))
(define-structure info-gateway (export info-handler
find-info-file
info-gateway-error)
(define-interface info-gateway-interface
(export info-handler
find-info-file
info-gateway-error))
(define-structure info-gateway info-gateway-interface
(open big-scheme
string-lib
conditions signals handle
switch-syntax
condhax
strings
htmlout-package
htmlout
httpd-core
httpd-error
url-package
uri-package
url
uri
scsh
scheme)
(files info-gateway))
(define-structure rman-gateway (export rman-handler
man
parse-man-entry
cat-man-page
find-man-file
file->man-directory
cat-n-decode
nroff-n-decode)
(define-interface rman-gateway-interface
(export rman-handler
man
parse-man-entry
cat-man-page
find-man-file
file->man-directory
cat-n-decode
nroff-n-decode))
(define-structure rman-gateway rman-gateway-interface
(open httpd-core
httpd-error
conditions
url-package
uri-package
htmlout-package
url
uri
htmlout
httpd-basic-handlers
switch-syntax
condhax
handle-fatal-error
scsh
let-opt
scheme)
(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
big-scheme bitwise
scsh)
(files ls))
(define-structure ftpd (export ftpd
ftpd-inetd)
(define-interface ftpd-interface
(export ftpd
ftpd-inetd))
(define-structure ftpd ftpd-interface
(open scheme
conditions handle signals
structure-refs
@ -432,3 +479,72 @@
crlf-io strings ls)
(access big-scheme)
(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
View File

@ -109,19 +109,20 @@
(values #f #f) ; Blank line or EOF terminates header text.
(? ((string-index line1 #\:) => ; Find the colon and
(lambda (colon) ; split out field name.
(let ((name (string->symbol-pref (substring line1 0 colon))))
;; Read in continuation lines.
(let lp ((lines (list (substring line1
(+ colon 1)
(string-length line1)))))
(let ((c (peek-char port))) ; Could return EOF.
(cond
((string-index line1 #\:) => ; Find the colon and
(lambda (colon) ; split out field name.
(let ((name (string->symbol-pref (substring line1 0 colon))))
;; Read in continuation lines.
(let lp ((lines (list (substring line1
(+ colon 1)
(string-length line1)))))
(let ((c (peek-char port))) ; Could return EOF.
;;; RFC822: continuous lines has to start with a space or a htab
(if (or (eqv? c #\space) (eqv? c htab))
(lp (cons (read-line port) lines))
(values name (reverse lines))))))))
(else (error "Illegal RFC 822 field syntax." line1)))))) ; No :
(if (or (eqv? c #\space) (eqv? c htab))
(lp (cons (read-line port) lines))
(values name (reverse lines))))))))
(else (error "Illegal RFC 822 field syntax." line1)))))) ; No :
;;; (read-rfc822-headers [port])
@ -146,17 +147,17 @@
(define (%read-rfc822-headers read-line port)
(let lp ((alist '()))
(receive (field val) (%read-rfc822-field read-line port)
(? (field (? ((assq field alist) =>
(lambda (entry)
(set-cdr! entry (cons val (cdr entry)))
(lp alist)))
(else (lp (cons (list field val) alist)))))
;; We are done. Reverse the order of each entry and return.
(else (for-each (lambda (entry)
(set-cdr! entry (reverse (cdr entry))))
alist)
alist)))))
(cond (field (cond ((assq field alist) =>
(lambda (entry)
(set-cdr! entry (cons val (cdr entry)))
(lp alist)))
(else (lp (cons (list field val) alist)))))
;; We are done. Reverse the order of each entry and return.
(else (for-each (lambda (entry)
(set-cdr! entry (reverse (cdr entry))))
alist)
alist)))))
;;; (rejoin-header-lines alist [separator])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

45
rman-gateway.scm
View File

@ -33,29 +33,30 @@
(man (:optional maybe-man man)))
(lambda (path req)
(switch string=? (request:method req)
(("GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(else
(decline))))
(let ((request-method (request:method req)))
(cond
((string=? request-method "GET")
(with-fatal-error-handler
(lambda (c decline)
(cond
((http-error? c)
(apply http-error (car (condition-stuff c)) req
(cddr (condition-stuff c))))
(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 (man-path entry and-then) (parse-man-url (request:url req))
(emit-man-page entry man man-path and-then reference-template))
(with-tag #t address ()
(display address))))
(else (http-error http-reply/method-not-allowed 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")))
(receive (man-path entry and-then) (parse-man-url (request:url req))
(emit-man-page entry man man-path and-then reference-template))
(with-tag #t address ()
(display address))))
(else (http-error http-reply/method-not-allowed req)))))))
(define (cat-man-page key section)
(let ((title (if section

15
scheme-program-server.scm
View File

@ -17,10 +17,11 @@
(http-log " Argumente : ~s~%" arglist)
(http-log "----------------------------------------~%")
(switch string=? (request:method req)
(("GET" "POST") ; Could do others also.
(wait (fork doit)))
(else (http-error http-reply/method-not-allowed req)))))
(let ((request-method (request:method req)))
(if (or (string=? request-method "GET")
(string=? request-method "POST")) ; Could do others also.
(wait (fork doit))
(http-error http-reply/method-not-allowed req))))
(http-error http-reply/bad-request req "Error "))))
@ -32,9 +33,9 @@
(define (split-and-decode-search-spec s)
(let recur ((i 0))
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
(recur (+ j 1)))))
(else (list (unescape-uri s i (string-length s)))))))
(cond ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
(recur (+ j 1)))))
(else (list (unescape-uri s i (string-length s)))))))
(define url-path)
(define script-path)

94
seval.scm
View File

@ -52,37 +52,40 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (seval-handler path req)
(switch string=? (request:method req)
(("POST") ; Could do others also.
(let ((request-method (request:method req)))
(cond
((string=? request-method "POST") ; Could do others also.
(let ((modern-protocol? (not (v0.9-request? req))))
(when modern-protocol?
(begin-http-header #t 200)
(write-string "Content-type: text/html\r\n\r\n"))
(with-tag #t HEAD ()
(newline)
(emit-title #t "Scheme program output"))
(newline))
(let ((modern-protocol? (not (v0.9-request? req))))
(if modern-protocol?
(begin
(begin-http-header #t 200)
(write-string "Content-type: text/html\r\n\r\n")))
(with-tag #t HEAD ()
(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 ()
(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))))
(else (http-error http-reply/method-not-allowed #f req)))))
;;; Read an HTTP request entity body from stdin. The Content-length:
@ -93,19 +96,20 @@
;;; and return it.
(define (read-request-sexp req)
(? ((get-header (request:headers req) 'content-length) =>
(lambda (cl-str) ; Take the first Content-length: header,
(let* ((cl-start (skip-whitespace cl-str)) ; skip whitespace,
(cl (if cl-start ; & convert to
(string->number (substring cl-str ; a number.
cl-start
(string-length cl-str)))
0)) ; All whitespace?? -- WTF.
(qs (read-string cl)) ; Read in CL chars,
(q (parse-html-form-query qs)) ; and parse them up.
(s (? ((assoc "program" q) => cdr)
(else (error "No program in entity body.")))))
(http-log "Seval sexp:~%~s~%" s)
(read (make-string-input-port s)))))
(else (http-error http-reply/bad-request req
"No Content-length: field in POST request."))))
(cond
((get-header (request:headers req) 'content-length) =>
(lambda (cl-str) ; Take the first Content-length: header,
(let* ((cl-start (skip-whitespace cl-str)) ; skip whitespace,
(cl (if cl-start ; & convert to
(string->number (substring cl-str ; a number.
cl-start
(string-length cl-str)))
0)) ; All whitespace?? -- WTF.
(qs (read-string cl)) ; Read in CL chars,
(q (parse-html-form-query qs)) ; and parse them up.
(s (cond ((assoc "program" q) => cdr)
(else (error "No program in entity body.")))))
(http-log "Seval sexp:~%~s~%" s)
(read (make-string-input-port s)))))
(else (http-error http-reply/bad-request req
"No Content-length: field in POST request."))))

46
smtp.scm
View File

@ -90,8 +90,8 @@
(define (filter-map f lis)
(let lp ((ans '()) (lis lis))
(if (pair? lis)
(lp (? ((f (car lis)) => (lambda (val) (cons val ans)))
(else ans))
(lp (cond ((f (car lis)) => (lambda (val) (cons val ans)))
(else ans))
(cdr lis))
(reverse ans))))
@ -269,20 +269,20 @@
;; We got a positive acknowledgement for the DATA msg,
;; now send the message body.
(let ((p (socket:outport socket)))
(? ((string? message)
(receive (data last-char) (smtp-stuff message #f)
(write-string data p)))
((input-port? message)
(let lp ((last-char #f))
(? ((read-string/partial 1024 message) =>
(lambda (chunk)
(receive (data last-char)
(smtp-stuff chunk last-char)
(write-string data p)
(lp last-char)))))))
(else (error "Message must be string or input-port.")))
(cond ((string? message)
(receive (data last-char) (smtp-stuff message #f)
(write-string data p)))
((input-port? message)
(let lp ((last-char #f))
(cond ((read-string/partial 1024 message) =>
(lambda (chunk)
(receive (data last-char)
(smtp-stuff chunk last-char)
(write-string data p)
(lp last-char)))))))
(else (error "Message must be string or input-port.")))
(write-string "\r\n.\r\n" p)
(force-output p)
@ -320,7 +320,7 @@
(let ((quit (nullary-smtp-command "QUIT")))
(lambda (socket)
(receive (code text) (quit socket) ; Quit & close socket gracefully.
(switchq = code
(case code
((221 421))
(else (close-socket socket))) ; But close in any event.
(values code text)))))
@ -339,7 +339,7 @@
(define (handle-smtp-reply socket)
(receive (code text) (read-smtp-reply (socket:inport socket))
(switchq = code
(case code
((221 421) (close-socket socket))) ; All done.
(values code text)))
@ -423,12 +423,12 @@
(if (< i slen)
(let ((c (string-ref s i)))
(string-set! ns j c)
(? ((and nl? (char=? c #\.))
(string-set! ns (+ j 1) #\.)
(lp #f (+ i 1) (+ j 2)))
(else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
(cond ((and nl? (char=? c #\.))
(string-set! ns (+ j 1) #\.)
(lp #f (+ i 1) (+ j 2)))
(else (lp (char=? c #\newline) (+ i 1) (+ j 1)))))))
ns))
(if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR
;;; Reply codes

80
uri.scm
View File

@ -110,16 +110,17 @@
(let lp ((i start) (j 0)) ; sweap over the string
(if (< j nlen)
(lp (? ((esc-seq? i) ; unescape
(lp (cond
((esc-seq? i) ; unescape
; escape-sequence
(string-set! ns j
(let ((d1 (string-ref s (+ i 1)))
(d2 (string-ref s (+ i 2))))
(ascii->char (+ (* 16 (hexchar->int d1))
(hexchar->int d2)))))
(+ i 3))
(else (string-set! ns j (string-ref s i))
(+ i 1)))
(string-set! ns j
(let ((d1 (string-ref s (+ i 1)))
(d2 (string-ref s (+ i 2))))
(ascii->char (+ (* 16 (hexchar->int d1))
(hexchar->int d2)))))
(+ i 3))
(else (string-set! ns j (string-ref s i))
(+ i 1)))
(+ j 1))))
ns)))))
@ -174,18 +175,19 @@
; character to escape with %ff where ff
; is the ascii-code in hexadecimal
; notation
(+ i (? ((char-set-contains? escaped-chars c)
(string-set! ns i #\%)
(let* ((d (char->ascii c))
(dhi (bitwise-and (arithmetic-shift d -4) #xF))
(dlo (bitwise-and d #xF)))
(string-set! ns (+ i 1)
(int->hexchar dhi))
(string-set! ns (+ i 2)
(int->hexchar dlo)))
3)
(else (string-set! ns i c)
1))))
(+ i (cond
((char-set-contains? escaped-chars c)
(string-set! ns i #\%)
(let* ((d (char->ascii c))
(dhi (bitwise-and (arithmetic-shift d -4) #xF))
(dlo (bitwise-and d #xF)))
(string-set! ns (+ i 1)
(int->hexchar dhi))
(string-set! ns (+ i 2)
(int->hexchar dlo)))
3)
(else (string-set! ns i c)
1))))
s)
ns)))))
@ -213,20 +215,21 @@
(rhead '()) ; CP prefix, reversed.
(j 0)) ; J counts sequential /
(? ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
(lp (cdr cp-tail)
(cons (car cp-tail) rhead)
(+ j 0)))
(cond
((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
(lp (cdr cp-tail)
(cons (car cp-tail) rhead)
(+ j 0)))
((= j numsl) ; Win
(values cscheme (simplify-uri-path (rev-append rhead p))))
((= j numsl) ; Win
(values cscheme (simplify-uri-path (rev-append rhead p))))
((pair? cp-tail) ; Keep looking.
(lp (cdr cp-tail)
(cons (car cp-tail) rhead)
1))
((pair? cp-tail) ; Keep looking.
(lp (cdr cp-tail)
(cons (car cp-tail) rhead)
1))
(else (values #f #f))))) ; Lose.
(else (values #f #f))))) ; Lose.
;; P doesn't begin with a slash.
@ -245,12 +248,13 @@
(define (split-uri-path uri start end) ; Split at /'s (infix grammar).
(let split ((i start)) ; "" -> ("")
(? ((>= i end) '(""))
((string-index uri #\/ i) =>
(lambda (slash)
(cons (substring uri i slash)
(split (+ slash 1)))))
(else (list (substring uri i end))))))
(cond
((>= i end) '(""))
((string-index uri #\/ i) =>
(lambda (slash)
(cons (substring uri i slash)
(split (+ slash 1)))))
(else (list (substring uri i end))))))
;;; The elements of PLIST must be escaped in case they contain slashes.

12
url.scm
View File

@ -144,9 +144,9 @@
(userhost->string (http-url:userhost url))
"/"
(uri-path-list->path (map escape-uri (http-url:path url)))
(? ((http-url:search url) =>
(lambda (s) (string-append "?" s)))
(else ""))
(? ((http-url:frag-id url) =>
(lambda (fi) (string-append "#" fi)))
(else ""))))
(cond ((http-url:search url) =>
(lambda (s) (string-append "?" s)))
(else ""))
(cond ((http-url:frag-id url) =>
(lambda (fi) (string-append "#" fi)))
(else ""))))