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
parent
a741498c59
commit
6c702e9a03
|
|
@ -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")
|
||||
((string=? request-method "GET")
|
||||
(parse-html-form-query (getenv "QUERY_STRING")))
|
||||
|
||||
(("POST")
|
||||
((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.
|
||||
|
|
|
|||
|
|
@ -112,20 +112,23 @@
|
|||
filename)))))
|
||||
|
||||
(http-log "search: ~s, argv: ~s~%" search argv)
|
||||
(switch string=? (request:method req)
|
||||
(("GET" "POST") ; Could do others also.
|
||||
(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))))
|
||||
(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)))))))
|
||||
|
||||
|
|
@ -190,15 +193,15 @@
|
|||
|
||||
,@request-invariant-cgi-env ; Stuff that never changes (see below).
|
||||
|
||||
,@(? ((http-url:search (request:url req)) =>
|
||||
,@(cond ((http-url:search (request:url req)) =>
|
||||
(lambda (srch) `(("QUERY_STRING" . ,srch))))
|
||||
(else '()))
|
||||
|
||||
,@(? ((get-header headers 'content-type) =>
|
||||
,@(cond ((get-header headers 'content-type) =>
|
||||
(lambda (ct) `(("CONTENT_TYPE" . ,ct))))
|
||||
(else '()))
|
||||
|
||||
,@(? ((get-header headers 'content-length) =>
|
||||
,@(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)))
|
||||
|
|
@ -239,7 +242,8 @@
|
|||
(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.
|
||||
(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))
|
||||
|
|
@ -251,17 +255,19 @@
|
|||
(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)
|
||||
(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))
|
||||
(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")
|
||||
(if (not (string=? (request:method req) "HEAD"))
|
||||
(begin
|
||||
(copy-inport->outport script-port out)
|
||||
(close-input-port script-port))))
|
||||
(close-input-port script-port)))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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,55 +386,65 @@
|
|||
(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?
|
||||
((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)))
|
||||
(when html-ok?
|
||||
(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?
|
||||
(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))))
|
||||
(if message (format out "~a~%" message)))))
|
||||
|
||||
((http-reply/forbidden)
|
||||
(unless html-ok?
|
||||
((= 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~%"
|
||||
(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))))
|
||||
(if message (format out "<P>~%~a~%" message)))))
|
||||
|
||||
((http-reply/not-found)
|
||||
(when html-ok?
|
||||
((= 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"
|
||||
(write-string
|
||||
"<P>The requested URL was not found on this server.\n"
|
||||
out)
|
||||
(if message (format out "<P>~%~a~%" message))))
|
||||
(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?
|
||||
(if html-ok?
|
||||
(begin
|
||||
(generic-title)
|
||||
(format out "The server encountered an internal error or
|
||||
misconfiguration and was unable to complete your request.
|
||||
|
|
@ -442,19 +452,21 @@ 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 "<P>~%~a~%" message))))
|
||||
(if message (format out "<P>~%~a~%" message)))))
|
||||
|
||||
((http-reply/not-implemented)
|
||||
(when html-ok?
|
||||
((= 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))))
|
||||
(if message (format out "<P>~a~%" message)))))
|
||||
|
||||
(else (if html-ok? (generic-title))))
|
||||
|
||||
(cond (html-ok?
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -201,8 +201,10 @@
|
|||
(if (file-name-directory? fname) ; Simple index generation.
|
||||
(directory-serve fname file-path req)
|
||||
|
||||
(switch string=? (request:method req)
|
||||
(("GET" "HEAD") ; Absolutely.
|
||||
(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)
|
||||
|
||||
|
|
@ -217,7 +219,7 @@
|
|||
|
||||
(else (http-error http-reply/forbidden req)))))
|
||||
|
||||
(else (http-error http-reply/method-not-allowed 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,16 +411,20 @@
|
|||
(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"))
|
||||
|
||||
(unless (eq? 'directory (file-info:type (stat-carefully fname req)))
|
||||
(if (not (eq? 'directory
|
||||
(file-info:type (stat-carefully fname req))))
|
||||
(http-error http-reply/forbidden req))
|
||||
|
||||
(unless (v0.9-request? 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"))
|
||||
(write-string "\r\n")))
|
||||
|
||||
(with-tag #t html ()
|
||||
(let ((title (string-append "Index of /"
|
||||
|
|
@ -424,14 +445,15 @@
|
|||
(emit-tag #t 'img
|
||||
(cons 'src (icon-name 'back))
|
||||
(cons 'alt "[UP ]"))
|
||||
(unless (null? file-path)
|
||||
(if (not (null? file-path))
|
||||
(begin
|
||||
(with-tag #t a ((href ".."))
|
||||
(write-string "Parent directory"))
|
||||
(newline))
|
||||
(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)
|
||||
(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))
|
||||
(? ((file-extension->content-type filename) =>
|
||||
(lambda (ct) (format out "Content-type: ~A\r~%" ct)))))
|
||||
(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))
|
||||
(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)
|
||||
(cond ((read-string! buf in) => (lambda (nchars)
|
||||
(write-string buf out 0 nchars)
|
||||
(loop))))))
|
||||
(force-output out))
|
||||
|
|
|
|||
|
|
@ -129,8 +129,9 @@
|
|||
(string-append "info?" node-name))))))
|
||||
|
||||
(lambda (path req)
|
||||
(switch string=? (request:method req)
|
||||
(("GET")
|
||||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(with-fatal-error-handler
|
||||
(lambda (c decline)
|
||||
(cond
|
||||
|
|
@ -157,7 +158,7 @@
|
|||
|
||||
(with-tag #t address ()
|
||||
(write-string address))))
|
||||
(else (http-error http-reply/method-not-allowed req))))))
|
||||
(else (http-error http-reply/method-not-allowed req)))))))
|
||||
|
||||
(define split-header-line
|
||||
(let ((split (infix-splitter "(, *)|( +)|( *\t *)"))
|
||||
|
|
|
|||
282
modules.scm
282
modules.scm
|
|
@ -1,8 +1,8 @@
|
|||
;;; Scheme 48 module definitions for TCP/IP protocol suites.
|
||||
;;; Copyright (c) 1995 by Olin Shivers.
|
||||
|
||||
(define-structures
|
||||
((smtp (export sendmail %sendmail
|
||||
(define-interface smtp-interface
|
||||
(export sendmail %sendmail
|
||||
expn vrfy mail-help
|
||||
smtp-transactions
|
||||
smtp-transactions/no-close
|
||||
|
|
@ -13,13 +13,18 @@
|
|||
read-smtp-reply
|
||||
parse-smtp-reply
|
||||
smtp-stuff))
|
||||
(smtp-internals (export read-crlf-line ; These two should be in an
|
||||
|
||||
(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)))
|
||||
unary-smtp-command))
|
||||
|
||||
(define-structures
|
||||
((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
|
||||
(define-interface crlf-io-interface
|
||||
(export read-crlf-line
|
||||
read-crlf-line-timeout
|
||||
write-crlf)
|
||||
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,16 +51,8 @@
|
|||
(files crlf-io))
|
||||
|
||||
|
||||
(define-structures ((switch-syntax (export (switch :syntax)
|
||||
(switchq :syntax)))
|
||||
(condhax (export (when :syntax)
|
||||
(unless :syntax)
|
||||
(? :syntax))))
|
||||
(open scheme)
|
||||
(files conditionals))
|
||||
|
||||
|
||||
(define-structure rfc822 (export read-rfc822-headers
|
||||
(define-interface rfc822-interface
|
||||
(export read-rfc822-headers
|
||||
read-rfc822-field
|
||||
%read-rfc822-headers
|
||||
%read-rfc822-field
|
||||
|
|
@ -62,9 +60,10 @@
|
|||
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,7 +76,8 @@
|
|||
(files rfc822))
|
||||
|
||||
|
||||
(define-structure strings (export string-map
|
||||
(define-interface strings-interface
|
||||
(export string-map
|
||||
downcase-string
|
||||
upcase-string
|
||||
char-set-index
|
||||
|
|
@ -86,23 +86,29 @@
|
|||
skip-whitespace
|
||||
string-prefix?
|
||||
string-suffix?
|
||||
trim-spaces)
|
||||
trim-spaces))
|
||||
|
||||
(define-structure strings strings-interface
|
||||
(open char-set-lib let-opt scheme)
|
||||
(files stringhax))
|
||||
|
||||
(define-structure uri-package (export parse-uri
|
||||
|
||||
(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)
|
||||
simplify-uri-path))
|
||||
|
||||
(define-structure uri uri-interface
|
||||
(open scsh-utilities
|
||||
string-lib
|
||||
let-opt
|
||||
receiving
|
||||
condhax
|
||||
|
||||
ascii
|
||||
strings
|
||||
char-set-lib
|
||||
|
|
@ -111,7 +117,9 @@
|
|||
scheme)
|
||||
(files uri))
|
||||
|
||||
(define-structure url-package (export userhost? ; USERHOST
|
||||
|
||||
(define-interface url-interface
|
||||
(export userhost? ; USERHOST
|
||||
make-userhost ; record struct
|
||||
|
||||
userhost:user
|
||||
|
|
@ -141,33 +149,43 @@
|
|||
set-http-url:frag-id
|
||||
|
||||
parse-http-url ; parse &
|
||||
http-url->string) ; unparse.
|
||||
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?
|
||||
(define-interface httpd-error-interface
|
||||
(export http-error?
|
||||
http-error
|
||||
fatal-syntax-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
|
||||
|
||||
(define-interface httpd-core-interface
|
||||
(export server/version
|
||||
server/protocol
|
||||
server/admin
|
||||
set-server/admin!
|
||||
|
|
@ -228,19 +246,18 @@
|
|||
|
||||
time->http-date-string
|
||||
begin-http-header
|
||||
set-http-header-beginner!
|
||||
send-http-error-reply
|
||||
|
||||
set-my-fqdn!
|
||||
set-my-port!)
|
||||
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
|
||||
(define-interface cgi-server-interface
|
||||
(export cgi-default-bin-path
|
||||
cgi-handler
|
||||
initialise-request-invariant-cgi-env)
|
||||
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,12 +316,12 @@
|
|||
scsh-utilities ; INDEX
|
||||
scsh ; syscalls
|
||||
formats ; format
|
||||
condhax ; ? is COND
|
||||
switch-syntax ; SWITCHQ
|
||||
scheme)
|
||||
(files cgi-server))
|
||||
|
||||
(define-structure htmlout-package (export emit-tag
|
||||
|
||||
(define-interface htmlout-interface
|
||||
(export emit-tag
|
||||
emit-close-tag
|
||||
|
||||
emit-p
|
||||
|
|
@ -306,11 +332,15 @@
|
|||
with-tag*
|
||||
|
||||
escape-html
|
||||
emit-text)
|
||||
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
|
||||
|
||||
(define-interface httpd-basic-handlers-interface
|
||||
(export alist-path-dispatcher
|
||||
home-dir-handler
|
||||
tilde-home-dir-handler
|
||||
rooted-file-handler
|
||||
|
|
@ -323,30 +353,31 @@
|
|||
send-file
|
||||
dotdot-check
|
||||
file-extension->content-type
|
||||
copy-inport->outport)
|
||||
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
|
||||
|
||||
(define-interface httpd-access-control-interface
|
||||
(export access-denier
|
||||
access-allower
|
||||
access-controller
|
||||
access-controlled-handler)
|
||||
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
|
||||
|
||||
(define-interface info-gateway-interface
|
||||
(export info-handler
|
||||
find-info-file
|
||||
info-gateway-error)
|
||||
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
|
||||
|
||||
(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)
|
||||
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)))))))
|
||||
|
|
|
|||
|
|
@ -109,7 +109,8 @@
|
|||
|
||||
(values #f #f) ; Blank line or EOF terminates header text.
|
||||
|
||||
(? ((string-index line1 #\:) => ; Find the colon and
|
||||
(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.
|
||||
|
|
@ -146,7 +147,7 @@
|
|||
(define (%read-rfc822-headers read-line port)
|
||||
(let lp ((alist '()))
|
||||
(receive (field val) (%read-rfc822-field read-line port)
|
||||
(? (field (? ((assq field alist) =>
|
||||
(cond (field (cond ((assq field alist) =>
|
||||
(lambda (entry)
|
||||
(set-cdr! entry (cons val (cdr entry)))
|
||||
(lp alist)))
|
||||
|
|
|
|||
|
|
@ -33,8 +33,9 @@
|
|||
(man (:optional maybe-man man)))
|
||||
|
||||
(lambda (path req)
|
||||
(switch string=? (request:method req)
|
||||
(("GET")
|
||||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((string=? request-method "GET")
|
||||
(with-fatal-error-handler
|
||||
(lambda (c decline)
|
||||
(cond
|
||||
|
|
@ -55,7 +56,7 @@
|
|||
|
||||
(with-tag #t address ()
|
||||
(display address))))
|
||||
(else (http-error http-reply/method-not-allowed req))))))
|
||||
(else (http-error http-reply/method-not-allowed req)))))))
|
||||
|
||||
(define (cat-man-page key section)
|
||||
(let ((title (if section
|
||||
|
|
|
|||
|
|
@ -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,7 +33,7 @@
|
|||
|
||||
(define (split-and-decode-search-spec s)
|
||||
(let recur ((i 0))
|
||||
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||
(cond ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||||
(recur (+ j 1)))))
|
||||
(else (list (unescape-uri s i (string-length s)))))))
|
||||
|
||||
|
|
|
|||
20
seval.scm
20
seval.scm
|
|
@ -52,13 +52,15 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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?
|
||||
(if modern-protocol?
|
||||
(begin
|
||||
(begin-http-header #t 200)
|
||||
(write-string "Content-type: text/html\r\n\r\n"))
|
||||
(write-string "Content-type: text/html\r\n\r\n")))
|
||||
(with-tag #t HEAD ()
|
||||
(newline)
|
||||
(emit-title #t "Scheme program output"))
|
||||
|
|
@ -67,7 +69,8 @@
|
|||
(with-tag #t BODY ()
|
||||
(newline)
|
||||
(let ((sexp (read-request-sexp req)))
|
||||
(do/timeout 10
|
||||
(do/timeout
|
||||
10
|
||||
(receive vals
|
||||
;; Do the computation.
|
||||
(begin (emit-header #t 2 "Output from execution")
|
||||
|
|
@ -82,7 +85,7 @@
|
|||
(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,7 +96,8 @@
|
|||
;;; and return it.
|
||||
|
||||
(define (read-request-sexp req)
|
||||
(? ((get-header (request:headers req) 'content-length) =>
|
||||
(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
|
||||
|
|
@ -103,7 +107,7 @@
|
|||
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)
|
||||
(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)))))
|
||||
|
|
|
|||
12
smtp.scm
12
smtp.scm
|
|
@ -90,7 +90,7 @@
|
|||
(define (filter-map f lis)
|
||||
(let lp ((ans '()) (lis lis))
|
||||
(if (pair? lis)
|
||||
(lp (? ((f (car lis)) => (lambda (val) (cons val ans)))
|
||||
(lp (cond ((f (car lis)) => (lambda (val) (cons val ans)))
|
||||
(else ans))
|
||||
(cdr lis))
|
||||
(reverse ans))))
|
||||
|
|
@ -269,13 +269,13 @@
|
|||
;; We got a positive acknowledgement for the DATA msg,
|
||||
;; now send the message body.
|
||||
(let ((p (socket:outport socket)))
|
||||
(? ((string? message)
|
||||
(cond ((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) =>
|
||||
(cond ((read-string/partial 1024 message) =>
|
||||
(lambda (chunk)
|
||||
(receive (data last-char)
|
||||
(smtp-stuff chunk last-char)
|
||||
|
|
@ -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,7 +423,7 @@
|
|||
(if (< i slen)
|
||||
(let ((c (string-ref s i)))
|
||||
(string-set! ns j c)
|
||||
(? ((and nl? (char=? c #\.))
|
||||
(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)))))))
|
||||
|
|
|
|||
12
uri.scm
12
uri.scm
|
|
@ -110,7 +110,8 @@
|
|||
|
||||
(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)))
|
||||
|
|
@ -174,7 +175,8 @@
|
|||
; character to escape with %ff where ff
|
||||
; is the ascii-code in hexadecimal
|
||||
; notation
|
||||
(+ i (? ((char-set-contains? escaped-chars c)
|
||||
(+ 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))
|
||||
|
|
@ -213,7 +215,8 @@
|
|||
(rhead '()) ; CP prefix, reversed.
|
||||
(j 0)) ; J counts sequential /
|
||||
|
||||
(? ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
|
||||
(cond
|
||||
((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s
|
||||
(lp (cdr cp-tail)
|
||||
(cons (car cp-tail) rhead)
|
||||
(+ j 0)))
|
||||
|
|
@ -245,7 +248,8 @@
|
|||
|
||||
(define (split-uri-path uri start end) ; Split at /'s (infix grammar).
|
||||
(let split ((i start)) ; "" -> ("")
|
||||
(? ((>= i end) '(""))
|
||||
(cond
|
||||
((>= i end) '(""))
|
||||
((string-index uri #\/ i) =>
|
||||
(lambda (slash)
|
||||
(cons (substring uri i slash)
|
||||
|
|
|
|||
4
url.scm
4
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) =>
|
||||
(cond ((http-url:search url) =>
|
||||
(lambda (s) (string-append "?" s)))
|
||||
(else ""))
|
||||
(? ((http-url:frag-id url) =>
|
||||
(cond ((http-url:frag-id url) =>
|
||||
(lambda (fi) (string-append "#" fi)))
|
||||
(else ""))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue