diff --git a/cgi-script.scm b/cgi-script.scm index 973ae87..49129cb 100644 --- a/cgi-script.scm +++ b/cgi-script.scm @@ -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. diff --git a/cgi-server.scm b/cgi-server.scm index 4c678a9..b012e5d 100644 --- a/cgi-server.scm +++ b/cgi-server.scm @@ -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))))) diff --git a/htmlout.scm b/htmlout.scm index 71d10d2..750f7af 100644 --- a/htmlout.scm +++ b/htmlout.scm @@ -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))) diff --git a/httpd-core.scm b/httpd-core.scm index a298a9e..f98a052 100644 --- a/httpd-core.scm +++ b/httpd-core.scm @@ -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 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 new location.~%" (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 "

Client sent a query that this server could not understand.\n" out) - (if message (format out "
~%Reason: ~A~%" message)))) + (if message (format out "
~%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 "

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 "

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 "

~%~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 "

~%~a~%" message))))) + + ((= reply-code http-reply/not-found) + (if html-ok? + (begin + (title-html out "URL not found" new-protocol?) + (write-string + "

The requested URL was not found on this server.\n" + out) + (if message (format out "

~%~a~%" message))))) - ((http-reply/not-found) - (when html-ok? - (title-html out "URL not found" new-protocol?) - (write-string "

The requested URL was not found on this server.\n" - out) - (if message (format out "

~%~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.

Please inform the server administrator, ~A, of the circumstances leading to the error, and time it occured.~%" - server/admin) - (if message (format out "

~%~a~%" message)))) + server/admin) + (if message (format out "

~%~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 "

~a~%" message)))) + (request:method req)) + (if message (format out "

~a~%" message))))) (else (if html-ok? (generic-title)))) - (cond (html-ok? - ;; Output extra stuff and close the tag. - (for-each (lambda (x) (format out "
~s~%" x)) extras) - (write-string "\n" out))) + (cond + (html-ok? + ;; Output extra stuff and close the tag. + (for-each (lambda (x) (format out "
~s~%" x)) extras) + (write-string "\n" out))) ; (force-output out) ;;; TODO check this ; (flush-all-ports) (force-output out) diff --git a/httpd-handlers.scm b/httpd-handlers.scm index 84ad026..e13ed6d 100644 --- a/httpd-handlers.scm +++ b/httpd-handlers.scm @@ -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)) diff --git a/info-gateway.scm b/info-gateway.scm index 9b9978d..0388993 100644 --- a/info-gateway.scm +++ b/info-gateway.scm @@ -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 *)")) diff --git a/modules.scm b/modules.scm index e259abf..1549f63 100644 --- a/modules.scm +++ b/modules.scm @@ -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))))))) diff --git a/rfc822.scm b/rfc822.scm index 7cc26ca..ce13ca2 100644 --- a/rfc822.scm +++ b/rfc822.scm @@ -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]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/rman-gateway.scm b/rman-gateway.scm index 8e1f842..a18f500 100644 --- a/rman-gateway.scm +++ b/rman-gateway.scm @@ -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 diff --git a/scheme-program-server.scm b/scheme-program-server.scm index 07a52c3..08152e1 100644 --- a/scheme-program-server.scm +++ b/scheme-program-server.scm @@ -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) diff --git a/seval.scm b/seval.scm index 4b5184f..c4b24d5 100644 --- a/seval.scm +++ b/seval.scm @@ -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.")))) diff --git a/smtp.scm b/smtp.scm index 22e7bf1..a3746dc 100644 --- a/smtp.scm +++ b/smtp.scm @@ -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 diff --git a/uri.scm b/uri.scm index a84207d..9795134 100644 --- a/uri.scm +++ b/uri.scm @@ -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. diff --git a/url.scm b/url.scm index f94ab73..1e1ecdd 100644 --- a/url.scm +++ b/url.scm @@ -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 ""))))