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

Moved from top-level directory.

This commit is contained in:
sperber 2002-06-08 15:07:01 +00:00
parent 7e137b2ce6
commit 3a166202d8
22 changed files with 6110 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1269
scheme/ftpd/ftpd.scm Normal file
View File

File diff suppressed because it is too large Load Diff

95
scheme/lib/cgi-script.scm Normal file
View File

@ -0,0 +1,95 @@
;;; NCSA's WWW Common Gateway Interface -- script-side code -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec".
;;; Imports and non-R4RS'isms
;;; switch (control structure)
;;; getenv read-string (scsh)
;;; error
;;; parse-html-form-query (parse-html-forms package)
;;; This file provides routines to help you write programs in Scheme
;;; that can interface to HTTP servers using the CGI program interface
;;; to carry out HTTP transactions.
;;; Other files/packages that will be of help:
;;; rfc822 For reading headers from entities.
;;; uri url For parsing and unparsing these things. Also for generally
;;; URI-decoding strings.
;;; htmlout For generating HTML output.
;;; About HTML forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This info is in fact independent of CGI, but important to know about,
;;; as many CGI scripts are written for responding to forms-entry in
;;; HTML browsers.
;;;
;;; The form's field data are turned into a single string, of the form
;;; name=val&name=val
;;; where the <name> and <val> parts are URI encoded to hide their
;;; &, =, and + chars, among other things. After URI encoding, the
;;; space chars are converted to + chars, just for fun. It is important
;;; to encode the spaces this way, because the perfectly general %xx escape
;;; mechanism might be insufficiently confusing. This variant encoding is
;;; called "form-url encoding."
;;;
;;; If the form's method is POST,
;;; Browser sends the form's field data in the entity block, e.g.,
;;; "button=on&ans=yes". The request's Content-type: is application/
;;; x-www-form-urlencoded, and the request's Content-length: is the
;;; number of bytes in the form data.
;;;
;;; If the form's method is GET,
;;; Browser sends the form's field data in the URL's <search> part.
;;; (So the server will pass to the CGI script as $QUERY_STRING,
;;; and perhaps also on in argv[]).
;;;
;;; In either case, the data is "form-url encoded" (as described above).
;;; ISINDEX queries:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (Likewise for ISINDEX URL queries from browsers.)
;;; Browser url-form encodes the query (see above), which then becomes the
;;; ?<search> part of the URI. (Hence the CGI script will split the individual
;;; fields into argv[].)
;;; CGI interface:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; - The URL's <search> part is assigned to env var $QUERY_STRING, undecoded.
;;; - If it contains no raw "=" chars, it is split at "+" chars. The
;;; substrings are URI decoded, and become the elts of argv[]. You aren't
;;; supposed to rely on this unless you are replying to ISINDEX queries.
;;; - The CGI script is run with stdin hooked up to the socket. If it's going
;;; to read the entity, it should read $CONTENT_LENGTH bytes worth.
;;; - A bunch of env vars are set with useful values.
;;; - Entity block is passed to script on stdin;
;;; script writes reply to stdout.
;;; - If the script begins with "nph-" its output is the entire reply.
;;; Otherwise, when it replies to the server, it sends back a special
;;; little header that tells the server how to construct the real header
;;; for the reply.
;;; See the "spec" for further details. (URL above)
;;; (cgi-form-query)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Return the form data as an alist of decoded strings.
;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist
;;; (("button" . "on") ("reply" . "Oh, yes"))
;;; This only works for GET and POST methods.
(define (cgi-form-query)
(let ((request-method (getenv "REQUEST_METHOD")))
(cond
((string=? request-method "GET")
(parse-html-form-query (getenv "QUERY_STRING")))
((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.

53
scheme/lib/crlf-io.scm Normal file
View File

@ -0,0 +1,53 @@
;;; Read cr/lf and lf terminated lines. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers. <shivers@lcs.mit.edu>
;;; External dependencies and non-R4RS'isms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ascii->char (To create a carriage-return)
;;; read-line write-string force-output (scsh I/O procs)
;;; receive values (MV return)
;;; let-optionals
;;; "\r\n" in strings for cr/lf. (Not R4RS)
;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read a line terminated by either line-feed or EOF. If RETAIN-CRLF? is #f
;;; (the default), a terminating cr/lf or lf sequence is trimmed from the
;;; returned string.
;;;
;;; This is simple and inefficient. It would be save one copy if we didn't
;;; use READ-LINE, but replicated its implementation instead.
(define (read-crlf-line . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f))
(let ((ln (read-line fd/port retain-crlf?)))
(if (or retain-crlf? (eof-object? ln))
ln
(let ((slen (string-length ln))) ; Trim a trailing cr, if any.
(if (or (zero? slen)
(not (char=? (string-ref ln (- slen 1)) cr)))
ln
(substring ln 0 (- slen 1))))))))
(define cr (ascii->char 13))
(define (write-crlf port)
(write-string "\r\n" port)
(force-output port))
(define (read-crlf-line-timeout . args)
(let-optionals args ((fd/port (current-input-port))
(retain-crlf? #f)
(timeout 8000)
(max-interval 500))
(let loop ((waited 0) (interval 100))
(cond ((> waited timeout)
'timeout)
((char-ready? fd/port)
(read-crlf-line fd/port retain-crlf?))
(else (sleep interval)
(loop (+ waited interval) (min (* interval 2)
max-interval)))))))

1221
scheme/lib/dns.scm Normal file
View File

File diff suppressed because it is too large Load Diff

57
scheme/lib/ecm-utilities.scm Normal file
View File

@ -0,0 +1,57 @@
;; ecm-utilities.scm -- Utility procedures for ecm-net code
;;
;; $Id: ecm-utilities.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;; please tell me if this doesn't work on your system.
(define (system-fqdn)
(let ((sysname (system-name)))
(if (string-index sysname #\.)
sysname
(nslookup-fqdn))))
;; This doesn't work on my system. Probably it is not configured well.
;; Nevertheless, the alternative seems better to me
;(define (nslookup-fqdn)
; (let* ((cmd (format #f "nslookup ~a" (system-name)))
; (raw (string-join (run/strings (nslookup ,(system-name)))))
; (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
; (display raw)
; (match:substring match 1)))
(define (nslookup-fqdn)
(host-info:name (host-info (system-name))))
; another easy alternative:
; (car (run/strings (hostname "--long"))))
;; prefer this to :optional
(define (safe-first x) (and (not (null? x)) (car x)))
(define (safe-second x) (and (not (null? x)) (not (null? (cdr x))) (cadr x)))
(define (write-crlf port)
(write-string "\r\n" port)
(force-output port))
(define (dump fd)
(let loop ((c (read-char fd)))
(cond ((not (eof-object? c))
(write-char c)
(loop (read-char fd))))))
(define-syntax when
(syntax-rules ()
((when bool body1 body2 ...)
(if bool (begin body1 body2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless bool body1 body2 ...)
(if (not bool) (begin body1 body2 ...)))))
;; EOF

32
scheme/lib/format-net.scm Normal file
View File

@ -0,0 +1,32 @@
;; Does pretty-print of internet-addresses (IPv4)
;; ADDRESS address to pretty-print
;; SEPERATOR optional, defaults to ".", seperator between address-parts
;; Example:
;; (format-internet-host-address #x0a00ffff)
;; ==> "10.0.255.255"
;; (format-internet-host-address #x0a00ffff ":")
;; ==> "10:0:255:255"
(define (format-internet-host-address address . maybe-separator)
(let ((extract (lambda (shift)
(number->string
(bitwise-and (arithmetic-shift address (- shift))
255)))))
(let-optionals maybe-separator ((separator "."))
(string-append
(extract 24) separator (extract 16) separator
(extract 8) separator (extract 0)))))
;; does pretty-print of ports
;; Example:
;; (format-port #x0aff)
;; => "10,255"
(define (format-port port)
(string-append
(number->string (bitwise-and (arithmetic-shift port -8) 255))
","
(number->string (bitwise-and port 255))))

24
scheme/lib/ftp-obsolete.scm Normal file
View File

@ -0,0 +1,24 @@
; maps obsolete ftp-procedure names to new ftp procedure names
; by Andreas Bernauer (2002)
(define ftp:connect ftp-connect)
(define ftp:login ftp-login)
(define ftp:type ftp-type)
(define ftp:rename ftp-rename)
(define ftp:delete ftp-delete)
(define ftp:cd ftp-cd)
(define ftp:cdup ftp-cdup)
(define ftp:pwd ftp-pwd)
(define ftp:rmdir ftp-rmdir)
(define ftp:mkdir ftp-mkdir)
(define ftp:modification-time ftp-modification-time)
(define ftp:size ftp-size)
(define ftp:abort ftp-abort)
(define ftp:quit ftp-quit)
(define ftp:ls ftp-ls)
(define ftp:dir ftp-dir)
(define ftp:get ftp-get)
(define ftp:put ftp-put)
(define ftp:append ftp-append)
(define ftp:quot ftp-quot)

575
scheme/lib/ftp.scm Normal file
View File

@ -0,0 +1,575 @@
;;; ftp.scm -- an FTP client library for the Scheme Shell
;;
;; $Id: ftp.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;;; Overview =========================================================
;;
;; This module lets you transfer files between networked machines from
;; the Scheme Shell, using the File Transfer Protocol as described
;; in rfc959. The protocol specifies the behaviour of a server
;; machine, which runs an ftp daemon (not implemented by this module),
;; and of clients (that's us) which request services from the server.
;;; Entry points =======================================================
;;
;; (ftp-connect host [logfile]) -> connection
;; Open a command connection with the remote machine HOST.
;; Optionally start logging the conversation with the server to
;; LOGFILE, which will be appended to if it already exists, and
;; created otherwise. Beware, the LOGFILE contains passwords in
;; clear text (it is created with permissions og-rxw) !
;;
;; (ftp-login connection [login passwd]) -> status
;; Log in to the remote host. If a login and password are not
;; provided, they are first searched for in the user's ~/.netrc
;; file, or default to user "anonymous" and password "user@host"
;;
;; (ftp-type connection type) -> status
;; Change the transfer mode for future data connections. This may
;; be either 'ascii or 'text, respectively, for transfering text files,
;; or 'binary for transfering binary files. If type is a string it
;; is sent verbatim to the server.
;;
;; (ftp-rename connection oldname newname) -> status
;; Change the name of oldname on the remote host to newname
;; (assuming sufficient permissions). oldname and newname are
;; strings; if prefixed with "/" they are taken relative to the
;; server's root, and otherwise they are relative to the current
;; directory. Note that in the case of anonymous ftp (user
;; "anonymous" or "ftp"), the server root is different from the
;; root of the servers's filesystem.
;;
;; (ftp-delete connection file) -> status
;; Delete file from the remote host (assuming the user has
;; appropriate permissions).
;;
;; (ftp-cd connection dir) -> status
;; Change the current directory on the server.
;;
;; (ftp-cdup connection) -> status
;; Move to the parent directory on the server.
;;
;; (ftp-pwd connection) -> string
;; Return the current directory on the remote host, as a string.
;;
;; (ftp-ls connection) -> status
;; Provide a listing of the current directory's contents, in short
;; format, ie as a list of filenames.
;;
;; (ftp-dir connection) -> status
;; Provide a listing of the current directory's contents, in long
;; format. Most servers (Unix, MS Windows, MacOS) use a standard
;; format with one file per line, with the file size and other
;; information, but other servers (VMS, ...) use their own format.
;;
;; (ftp-get connection remote-file [local-file]) -> status | string
;; Download remote-file from the FTP server. If local-file is a
;; string, save the data to local-file on the local host;
;; otherwise save to a local file named remote-file. remote-file
;; and local-file may be absolute file names (with a leading `/'),
;; or relative to the current directory. It local-file is #t,
;; output data to (current-output-file), and if it is #f return
;; the data as a string.
;;
;; (ftp-put connection local-file [remote-file]) -> status
;; Upload local-file to the FTP server. If remote-file is
;; specified, the save the data to remote-file on the remote host;
;; otherwise save to a remote file named local-file. local-file
;; and remote-file may be absolute file names (with a leading
;; `/'), or relative to the current directory.
;;
;; (ftp-rmdir connection dir) -> status
;; Remove the directory DIR from the remote host (assuming
;; sufficient permissions).
;;
;; (ftp-mkdir connection dir) -> status
;; Create a new directory named DIR on the remote host (assuming
;; sufficient permissions).
;;
;; (ftp-modification-time connection file) -> date
;; Request the time of the last modification of FILE on the remote
;; host, and on success return a Scsh date record. This command is
;; not part of RFC959 and is not implemented by all servers, but
;; is useful for mirroring.
;;
;; (ftp-size connection file) -> integer
;; Return the size of FILE in bytes.
;;
;; (ftp-abort connection) -> status
;; Abort the current data transfer. Not particularly useful with
;; this implementation since the data transfer commands only
;; return once the transfer is complete.
;;
;; (ftp-quit connection) -> status
;; Close the connection to the remote host. The connection object
;; is useless after a quit command.
;;; Unimplemented =====================================================
;;
;; This module has no support for sites behind a firewall (because I
;; am unable to test it). It shouldn't be very tricky; it only
;; requires using passive mode. Might want to add something like the
;; /usr/bin/ftp command `restrict', which implements data port range
;; restrictions.
;;
;; The following rfc959 commands are not implemented:
;;
;; * ACCT (account; this is ignored by most servers)
;; * SMNT (structure mount, for mounting another filesystem)
;; * REIN (reinitialize connection)
;; * LOGOUT (quit without interrupting ongoing transfers)
;; * STRU (file structure)
;; * ALLO (allocate space on server)
;;; Portablitity =====================================================
;;
;; * the netrc.scm module for parsing ~/.netrc files
;; * scsh socket code
;; * scsh records
;; * receive for multiple values
;; * Scheme48 signals/handlers
;;; Related work ======================================================
;;
;; * rfc959 describes the FTP protocol; see
;; http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
;;
;; * /anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz is a
;; library similar to this one, written in C, by Thomas Pfau
;;
;; * FTP.pm is a Perl module with similar functionality (available
;; from http://www.perl.com/CPAN)
;;
;; * Emacs gets transparent remote file access from ange-ftp.el by
;; Ange Norman. However, it cheats by using /usr/bin/ftp
;;
;; * Siod (a small-footprint Scheme implementation by George Carette)
;; comes with a file ftp.scm with a small subset of these functions
;; defined
;;; TODO ============================================================
;;
;; * handle passive mode and firewalls
;; * Unix-specific commands such as SITE UMASK, SITE CHMOD
;; * object-based interface? (like SICP message passing)
;; * improved error handling
;; * a lot of the calls to format could be replaced by calls to
;; string-join. Maybe format is easier to read?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Communication is initiated by the client. The server responds to
;; each request with a three digit status code and an explanatory
;; message, and occasionally with data (which is sent via a separate,
;; one-off channel). The client starts by opening a command connection
;; to a well known port on the server machine. Messages send to the
;; server are of the form
;;
;; CMD [ <space> arg ] <CR> <LF>
;;
;; Replies from the server are of the form
;;
;; xyz <space> Informative message <CR> <LF>
;;
;; where xyz is a three digit code which indicates whether the
;; operation succeeded or not, whether the server is waiting for more
;; data, etc. The server may also send multiline messages of the form
;;
;; xyz- <space> Start of multiline message <CR> <LF>
;; [ <space>+ More information ]* <CR> <LF>
;; xyz <space> End of multiline message <CR> <LF>
;;
;; Some of the procedures in this module extract useful information
;; from the server's reply, such as the size of a file, or the name of
;; the directory we have moved to. These procedures return either the
;; extracted information, or #f to indicate failure. Other procedures
;; return a "status", which is either the server's reply as a string,
;; or #f to signify failure.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; beware, the log file contains password information!
;;: string [ x string x port] -> connection
(define (ftp-connect host . args)
(let-optionals* args ((logfile #f))
(let* ((LOG (and logfile
(open-output-file logfile
(if (file-exists? logfile)
(bitwise-ior open/write open/append)
(bitwise-ior open/write open/create))
#o600)))
(hst-info (host-info host))
(hostname (host-info:name hst-info))
(srvc-info (service-info "ftp" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
hostname
(service-info:port srvc-info)))
(connection (make-ftp-connection hostname
sock
LOG "" "")))
(ftp-log connection
(format #f "~%-- ~a: opened ftp connection to ~a"
(date->string (date)) ; doesn't seem to be buggy in v0.6
;"Dummy date" ; (format-time-zone) is buggy in v0.5.1
hostname))
(ftp-read-response connection "220") ; the initial welcome banner
connection)))
;; Send user information to the remote host. Args are optional login
;; and password. If they are not provided, the Netrc module is used to
;; try to determine a login and password for the server. If not found we
;; default to login "anonymous" with password user@host.
;;: connection [ x string x password ] -> status
(define (ftp-login connection . args)
(let ((netrc-record (netrc:parse)))
(let-optionals* args
((login
(netrc:lookup-login netrc-record
(ftp-connection:host-name connection)))
(password
(netrc:lookup-password netrc-record
(ftp-connection:host-name connection))))
(set-ftp-connection:login connection login)
(set-ftp-connection:password connection password)
(ftp-send-command connection (format #f "USER ~a" login) "...") ; "331"
(ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230"
;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
;; sent verbatim
;;: connection x symbol|string -> status
(define (ftp-type connection type)
(let ((ttype (cond
((string? type) type)
((eq? type 'binary) "I")
((or (eq? type 'ascii)
(eq? type 'text)) "A")
(else
(call-error "type must be one of 'binary or 'text or 'ascii" ftp-type type)))))
(ftp-send-command connection (format #f "TYPE ~a" ttype))))
;;: connection x string x string -> status
(define (ftp-rename connection oldname newname)
(ftp-send-command connection (format #f "RNFR ~a" oldname) "35.")
(ftp-send-command connection (format #f "RNTO ~a" newname) "25."))
;;: connection x string -> status
(define (ftp-delete connection file)
(ftp-send-command connection (format #f "DELE ~a" file) "25."))
;;: connection x string -> status
(define (ftp-cd connection dir)
(ftp-send-command connection (format #f "CWD ~a" dir)))
;;: connection -> status
(define (ftp-cdup connection)
(ftp-send-command connection "CDUP" "250"))
;;: on success return the new directory as a string
(define (ftp-pwd connection)
(let* ((response (ftp-send-command connection "PWD" "2..")) ;; 257
(match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response ""))))
(match:substring match 1)))
;;: connection x string -> status
(define (ftp-rmdir connection dir)
(ftp-send-command connection (format #f "RMD ~a" dir)))
;;: connection x string -> status
(define (ftp-mkdir connection dir)
(ftp-send-command connection (format #f "MKD ~a" dir)))
;; On success return a Scsh date record. This message is not part of
;; rfc959 but seems to be supported by many ftp servers (it's useful
;; for mirroring)
;;: connection x string -> date
(define (ftp-modification-time connection file)
(let* ((response (ftp-send-command connection
(format #f "MDTM ~a" file)))
(match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response "")))
(timestr (and match (match:substring match 1))))
(and timestr
(let ((year (substring timestr 0 4))
(month (substring timestr 4 6))
(mday (substring timestr 6 8))
(hour (substring timestr 8 10))
(min (substring timestr 10 12))
(sec (substring timestr 12 14)))
(make-date (string->number sec)
(string->number min)
(string->number hour)
(string->number mday)
(string->number month)
(- (string->number year) 1900))))))
;; On success return the size of the file in bytes.
;;: connection x string -> integer
(define (ftp-size connection file)
(let* ((response (ftp-send-command connection
(format #f "SIZE ~a" file)
"2..")))
(and (string? response)
(string->number (substring response
4 (- (string-length response) 1))))))
;; Abort the current data transfer. Maybe we should close the data
;; socket?
;;: connection -> status
(define (ftp-abort connection)
(ftp-send-command connection "ABOR"))
;;: connection -> status
(define (ftp-quit connection)
(ftp-send-command connection "QUIT" "221")
(close-socket (ftp-connection:command-socket connection)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following commands require the use of a data connection as well
;; as the command connection. The command and the server's reply are
;; transmitted via the command connection, while the data is
;; transmitted via the data connection (you could have guessed that,
;; right?).
;;
;; The data socket is created by the client, who sends a PORT command
;; to the server to indicate on which port it is ready to accept a
;; connection. The port command specifies an IP number and a port
;; number, in the form of 4+2 comma-separated bytes. The server then
;; initiates the data transfer. A fresh data connection is created for
;; each data transfer (unlike the command connection which stays open
;; during the entire conversation with the server).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;: connection [ x string ] -> status
(define (ftp-ls connection . maybe-dir)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(ftp-build-command-string "NLST" maybe-dir)
"1..")
(receive (newsock newsockaddr)
(accept-connection sock)
(dump (socket:inport newsock))
(close-socket newsock)
(close-socket sock)
(ftp-read-response connection "2.."))))
;;: connection [ x string ] -> status
(define (ftp-dir connection . maybe-dir)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(ftp-build-command-string "LIST" maybe-dir)
"1..")
(receive (newsock newsockaddr)
(accept-connection sock)
(dump (socket:inport newsock))
(close-socket newsock)
(close-socket sock)
(ftp-read-response connection "2.."))))
;; maybe-local may be a filename to which the data should be written,
;; or #t to write data to stdout (to current-output-port to be more
;; precise), or #f to stuff the data in a string (which is returned),
;; or nothing to output to a local file with the same name as the
;; remote file.
;;: connection x string [x string | #t | #f] -> status | string
(define (ftp-get connection remote-file . maybe-local)
(let* ((sock (ftp-open-data-connection connection))
(local (if (pair? maybe-local)
(car maybe-local)
'empty))
(OUT (cond ((string? local) (open-output-file local))
((eq? local #t) (current-output-port))
((eq? local #f) (make-string-output-port))
(else
(open-output-file remote-file)))))
(ftp-send-command connection
(format #f "RETR ~a" remote-file)
"150")
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port OUT
(dump (socket:inport newsock)))
(close-socket newsock)
(close-socket sock)
(let ((status (ftp-read-response connection "2..")))
(if (string? local) (close OUT))
(if (eq? local #f)
(string-output-port-output OUT)
status)))))
;; FIXME: should have an optional argument :rename which defaults to
;; false, which would make us upload to a temporary name and rename at
;; the end of the upload. This atomicity is important for ftp or http
;; servers which are serving a load, and to avoid problems with "no
;; space on device".
;; optional argument maybe-remote-file is the name under which we wish
;; the file to appear on the remote machine. If omitted the file takes
;; the same name on the FTP server as on the local host.
;;: connection x string [ x string ] -> status
(define (ftp-put connection local-file . maybe-remote-file)
(let-optionals* maybe-remote-file ((remote-file #f))
(let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file))
(cmd (format #f "STOR ~a" (or remote-file local-file))))
(ftp-send-command connection cmd "150")
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port (socket:outport newsock) (dump IN))
(close (socket:outport newsock)) ; send the server EOF
(close-socket newsock)
(let ((status (ftp-read-response connection "2..")))
(close IN)
(close-socket sock)
status)))))
;;: connection x string [x string] -> status
(define (ftp-append connection local-file . maybe-remote-file)
(let-optionals* maybe-remote-file ((remote-file #f))
(let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file))
(cmd (format #f "APPE ~a" (or remote-file local-file))))
(ftp-send-command connection cmd "150")
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port (socket:outport newsock)
(dump IN))
(close (socket:outport newsock)) ; send the server EOF
(close-socket newsock)
(let ((status (ftp-read-response connection "2..")))
(close IN)
(close-socket sock)
status)))))
;; send a command verbatim to the remote server and wait for a
;; response.
;;: connection x string -> status
(define (ftp-quot connection cmd)
(ftp-send-command connection cmd))
;; ------------------------------------------------------------------------
;; no exported procedures below
(define (ftp-open-data-connection connection)
(let* ((sock (create-socket protocol-family/internet
socket-type/stream))
(sockaddr (internet-address->socket-address
internet-address/any
0))) ; 0 to accept any port
(set-socket-option sock level/socket socket/reuse-address #t)
(set-socket-option sock level/socket socket/linger 120)
(bind-socket sock sockaddr)
(listen-socket sock 0)
(ftp-send-command connection ; send PORT command
(ftp-build-PORT-string (socket-local-address sock)))
sock))
;; TODO: Unix-specific commands
;; SITE UMASK 002
;; SITE IDLE 60
;; SITE CHMOD 755 filename
;; SITE HELP
;; We cache the login and password to be able to relogin automatically
;; if we lose the connection (a la ange-ftp). Not implemented.
(define-record ftp-connection
host-name
command-socket
logfd
login
password)
(define-condition-type 'ftp-error '(error))
(define ftp-error? (condition-predicate 'ftp-error))
(define (ftp-build-PORT-string sockaddr)
(let* ((hst-info (host-info (system-name)))
(ip-address (car (host-info:addresses hst-info))))
(receive (hst-address srvc-port)
(socket-address->internet-address sockaddr)
(let* ((num32 ip-address)
(num24 (arithmetic-shift num32 -8))
(num16 (arithmetic-shift num24 -8))
(num08 (arithmetic-shift num16 -8))
(byte0 (bitwise-and #b11111111 num08))
(byte1 (bitwise-and #b11111111 num16))
(byte2 (bitwise-and #b11111111 num24))
(byte3 (bitwise-and #b11111111 num32)))
(format #f "PORT ~a,~a,~a,~a,~a,~a"
byte0 byte1 byte2 byte3
(arithmetic-shift srvc-port -8) ; high order byte
(bitwise-and #b11111111 srvc-port) ; lower order byte
)))))
(define (ftp-send-command connection command . maybe-expected)
(let-optionals* maybe-expected ((expected "2.."))
(let* ((sock (ftp-connection:command-socket connection))
(OUT (socket:outport sock)))
(write-string command OUT)
(write-crlf OUT)
(ftp-log connection (format #f "<- ~a" command))
(ftp-read-response connection expected))))
;; This is where we check that the server's 3 digit status code
;; corresponds to what we expected. EXPECTED is a string of the form
;; "250", which indicates we are expecting a 250 code from the server,
;; or "2.." which means that we only require the first digit to be 2
;; and don't care about the rest. If the server's response doesn't
;; match EXPECTED, we raise an ftp-error (which is catchable; look at
;; pop3.scm to see how). Since this is implemented as a regexp, you
;; can also specify more complicated acceptable responses of the form
;; "2[4-6][0-9]". The code permits you to match the server's verbose
;; message too, but beware that the messages change from server to
;; server.
(define (ftp-read-response connection . maybe-expected)
(let-optionals* maybe-expected ((expected "2.."))
(let* ((sock (ftp-connection:command-socket connection))
(IN (socket:inport sock))
(response (read-line IN)))
(ftp-log connection (format #f "-> ~a" response))
(or (string-match expected response)
(signal 'ftp-error response))
;; handle multi-line responses
(if (equal? (string-ref response 3) #\-)
(let loop ((code (string-append (substring response 0 3) " "))
(line (read-line IN)))
(ftp-log connection (format #f "-> ~a" line))
(set! response (string-join (list response line "\n")))
(or (string-match code line)
(loop code (read-line IN)))))
response)))
(define (ftp-build-command-string str . opt-args)
(if (string? opt-args)
(string-join (list str arg))
str))
(define (ftp-log connection line)
(let ((LOG (ftp-connection:logfd connection)))
(and LOG
(write-string line LOG)
(write-string "\n" LOG)
(force-output LOG))))
;; EOF

195
scheme/lib/htmlout.scm Normal file
View File

@ -0,0 +1,195 @@
;;; Simple code for doing structured html output. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; External dependencies
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; format ; Output
;;; receive values ; Multiple-value return
;;; - An attribute-quoter, that will map an attribute value to its
;;; HTML text representation -- surrounding it with single or double quotes,
;;; as appropriate, etc.
;;; Printing HTML tags.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All the emit-foo procedures have the same basic calling conventions:
;;; (emit-foo out <required values> ... [<extra attributes> ...])
;;; - OUT is either a port or #t for the current input port.
;;; - Each attribute is either a (name . value) pair, which is printed as
;;; name="value"
;;; or a single symbol or string, which is simply printed as-is
;;; (this is useful for attributes that don't have values, such as the
;;; ISMAP attribute in <img> tags).
;;; <tag name1="val1" name2="val2" ...>
(define (emit-tag out tag . attrs)
(let ((out (fmt->port out)))
(display "<" out)
(display tag out)
(for-each (lambda (attr)
(display #\space out)
(cond ((pair? attr) ; name="val"
(display (car attr) out)
(display "=\"" out) ; Should check for
(display (cdr attr) out) ; internal double-quote
(display #\" out)) ; etc.
(else
(display attr out)))) ; name
attrs)
(display #\> out)))
;;; </tag>
(define (emit-close-tag out tag)
(format out "</~a>" tag))
;;; <P>
(define (emit-p . args) ; (emit-p [out attr1 ...])
(receive (out attrs) (if (pair? args)
(let* ((out (car args)))
(values (if (eq? out #t) (current-output-port) out)
(cdr args)))
(values (current-output-port) args))
(apply emit-tag out 'p attrs)
(newline out)
(newline out)))
;;; <TITLE> Make Money Fast!!! </TITLE>
(define (emit-title out title) ; Takes no attributes.
(format out "<title>~a~%</title>~%" title))
(define (emit-header out level text . attribs)
(apply with-tag* out (string-append "H" (number->string level))
(lambda () (display text (fmt->port out)))
attribs))
;;; ...and so forth. Could stand to define a bunch of little emitters for the
;;; various tags. (define-tag-emitter ...)
;;; Printing out balanced <tag> ... </tag> pairs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (with-tag out tag (attr-elt ...) body ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Execute the body forms between a <tag attrs> ... </tag> pair.
;;; The (ATTR-ELT ...) list specifies the attributes for the <tag>.
;;; It is rather like a LET-list, having the form
;;; ((name val) ...)
;;; Each NAME must be a symbol, and each VAL must be a Scheme expression
;;; whose value is the string to use as attribute NAME's value. Attributes
;;; that have no value (e.g., ISMAP) can be specified as attr-elt NAME,
;;; instead of (NAME VALUE).
;;;
;;; For example,
;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page.
;;; (with-tag port A ((href hp-url) (name "hp"))
;;; (display "home page" port)))
;;; outputs
;;; <A href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</A>
(define-syntax with-tag
(syntax-rules ()
((with-tag out tag (attr-elt ...) body ...)
(with-tag* out 'tag (lambda () body ...)
(%hack-attr-elt attr-elt)
...))))
;;; Why does this have to be top-level?
;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
(define-syntax %hack-attr-elt
(syntax-rules () ; Build attribute-list element:
((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt)
(cons 'name val))
((%hack-attr-elt name) 'name))) ; name => 'name
;;; Execute THUNK between a <tag attrs> ... </tag> pair.
(define (with-tag* out tag thunk . attrs)
(apply emit-tag out tag attrs)
(let ((out (fmt->port out)))
(call-with-values thunk
(lambda results
(newline out)
(emit-close-tag out tag)
(apply values results)))))
(define (fmt->port x)
(if (eq? x #t) (current-output-port) x))
;;; Translate text to HTML, mapping special chars such as <, >, &, and
;;; double-quote to their HTML escape sequences.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Note iso8859-1 above 127 is perfectly OK
(define *html-entity-alist*
(list
(cons (ascii->char 60) "&lt;")
(cons (ascii->char 62) "&gt;")
(cons (ascii->char 38) "&amp;")
(cons (ascii->char 34) "&quot;")))
(define *html-entities*
(list->char-set (map car *html-entity-alist*)))
(define *html-entity-table*
(let ((v (make-vector 256 #f)))
(for-each (lambda (entry)
(vector-set! v
(char->ascii (car entry))
(cdr entry)))
*html-entity-alist*)
v))
(define (string-set-substring! t start s)
(let* ((l (string-length s))
(end (+ l start)))
(do ((i start (+ 1 i)))
((= i end) t)
(string-set! t i (string-ref s (- i start))))))
(define (escape-html s)
(let ((target-length
(string-fold (lambda (c i)
(+ i
(if (char-set-contains? *html-entities* c)
(string-length
(vector-ref *html-entity-table*
(char->ascii c)))
1)))
0
s)))
(if (= target-length (string-length s))
s
(let ((target (make-string target-length)))
(string-fold
(lambda (c i)
(+ i
(if (char-set-contains? *html-entities* c)
(let ((entity (vector-ref *html-entity-table* (char->ascii c))))
(string-set-substring! target i entity)
(string-length entity))
(begin
(string-set! target i c)
1))))
0
s)
target))))
(define (emit-text s . maybe-port)
(if (null? maybe-port)
(write-string (escape-html s))
(write-string (escape-html s) (fmt->port (car maybe-port)))))

332
scheme/lib/ls.scm Normal file
View File

@ -0,0 +1,332 @@
; ls clone in scsh
; Mike Sperber <sperber@informatik.uni-tuebingen.de>
; Copyright (c) 1998 Michael Sperber.
; This currently does a whole bunch of stats on every file in some
; cases. In a decent OS implementation, this stuff is cached, so
; there isn't any problem, at least not in theory :-)
; FLAGS is a list of symbols from:
;
; all - include stuff starting with "."
; recursive - guess what
; long - output interesting information per file
; directory - display only the information for the directory named
; flag - flag files as per their types
; columns - sorts output vertically in a multicolumn format
(define ls-crlf? (make-fluid #f))
(define (ls flags paths . maybe-port)
(let* ((port (optional maybe-port (current-output-port)))
(paths (if (null? paths)
(list (cwd))
paths))
(only-one? (null? (cdr paths))))
(call-with-values
(lambda () (parse-flags flags))
(lambda (all? recursive? long? directory? flag? columns?)
(real-ls paths
(if only-one? #f "")
all? recursive? long? directory? flag? columns?
port)))))
(define (parse-flags flags)
(let ((all? (memq 'all flags))
(recursive? (memq 'recursive flags))
(long? (memq 'long flags))
(directory? (memq 'directory flags))
(flag? (memq 'flag flags))
(columns? (memq 'columns flags)))
(values all? recursive? long? directory? flag? columns?)))
(define (real-ls paths prefix
all? recursive? long? directory? flag? columns?
port)
(let ((first #t))
(for-each
(lambda (path)
(if first
(set! first #f)
(ls-newline port))
(if prefix
(format port "~A~A:~%" prefix path))
(ls-path path all? recursive? long? directory? flag? columns? port))
paths)))
(define (ls-path path all? recursive? long? directory? flag? columns? port)
(cond
((and (not directory?) ;; go into directories
(or (and (file-name-directory? path) ;; path specifies directory
(file-directory? path #t)) ;; either as a symlink (if the names end with a slash)
(file-directory? path #f))) ;; or not
(ls-directory path all? recursive? long? directory? flag? columns? port))
(else
(if (or long? flag?) ;; see LS-DIRECTORY for details
(ls-file (cons path (file-info path #f)) long? flag? port)
(ls-file (cons path #f) long? flag? port)))))
(define (ls-directory directory all? recursive? long? directory? flag? columns? port)
; terminology: a FILE-NAME is the name of a file
; a FILE is a pair whose car is a file-name and whose cdr is
; either its file-info-object or #f (if not needed)
; a INFO is a file-info-object
(let* ((directory (file-name-as-directory directory))
(substantial-directory (string-append directory "."))
(file-names (directory-files substantial-directory all?)))
(with-cwd*
substantial-directory
(lambda ()
(let ((files (if (or recursive? long? flag?) ; these are the flags for which we need the file-info
(map (lambda (file-name)
(cons file-name (file-info file-name #f)))
file-names)
(map (lambda (file-name) (cons file-name #f))
file-names))))
(if (and (not long?)
columns?)
(ls-files-columns files flag? port)
(ls-files-column files long? flag? port))
(if recursive?
(let ((directories
(map (lambda (file) (car file))
(filter (lambda (file)
(eq? (file-info:type (cdr file)) 'directory))
files))))
(if (not (null? directories))
(begin
(ls-newline port)
(real-ls directories directory
all? recursive? long? directory? flag? columns?
port))))))))))
(define *width* 79)
(define (ls-files-columns files flag? port)
(let* ((max-file-name-width
(if (null? files)
0
(apply max (map (lambda (file) (string-length (car file))) files))))
(max-file-name-width
(if flag?
(+ 1 max-file-name-width)
max-file-name-width))
(column-width (+ 2 max-file-name-width))
(columns (quotient *width*
column-width))
(columns (if (zero? columns)
1
columns))
(number-of-files (length files))
(rows (quotient (+ number-of-files (- columns 1))
columns))
(tails
(do ((column 0 (+ 1 column))
(tails (make-vector columns)))
((= column columns)
tails)
(vector-set! tails column
(list-tail-or-null files (* rows column))))))
(do ((row 0 (+ 1 row)))
((= row rows))
(do ((column 0 (+ 1 column)))
((= column columns))
(let ((tail (vector-ref tails column)))
(if (not (null? tail))
(let* ((file (car tail))
(width (display-file file flag? port)))
(display-spaces (- column-width width) port)
(vector-set! tails column (cdr tail))))))
(ls-newline port))))
(define (list-tail-or-null list index)
(let loop ((list list) (index index))
(cond
((null? list) list)
((zero? index) list)
(else (loop (cdr list) (- index 1))))))
(define (ls-files-column files long? flag? port)
(for-each
(lambda (file)
(ls-file file long? flag? port))
files))
(define (ls-file file long? flag? port)
(if long?
(ls-file-long file flag? port)
(ls-file-short file flag? port)))
(define (ls-file-short file flag? port)
(display-file file flag? port)
(ls-newline port))
(define (ls-file-long file flag? port)
(let ((info (cdr file)))
(display-permissions info port)
(display-decimal-justified (file-info:nlinks info) 4 port)
(write-char #\space port)
(let* ((uid (file-info:uid info))
(user-name
(call-with-current-continuation
(lambda (escape)
(with-handler
(lambda (condition more)
(escape (number->string uid)))
(lambda ()
(user-info:name (user-info uid))))))))
(display-padded user-name 9 port))
(let* ((gid (file-info:gid info))
(group-name
(call-with-current-continuation
(lambda (escape)
(with-handler
(lambda (condition more)
(escape (number->string gid)))
(lambda ()
(group-info:name (group-info gid))))))))
(display-padded group-name 9 port))
(display-decimal-justified (file-info:size info) 7 port)
(write-char #\space port)
(display-time (file-info:mtime info) port)
(write-char #\space port)
(display-file file flag? port)
(if (eq? (file-info:type info) 'symlink)
(begin
(display " -> " port)
(display (read-symlink (car file)) port)))
(ls-newline port)))
(define *year-seconds* (* 365 24 60 60))
(define (display-time the-time port)
(let ((time-difference (abs (- (time) the-time)))
(date (date the-time 0)))
(if (< time-difference *year-seconds*)
(display (format-date "~b ~d ~H:~M" date) port)
(display (format-date "~b ~d ~Y " date) port))))
(define (display-file file flag? port)
(let ((file-name (car file)))
(display file-name port)
(if (maybe-display-flag (cdr file) flag? port)
(+ 1 (string-length file-name))
(string-length file-name))))
(define (maybe-display-flag info flag? port)
(and flag?
(begin
(cond
((eq? (file-info:type info) 'directory)
(write-char #\/ port))
((eq? (file-info:type info) 'symlink)
(write-char #\@ port))
; 'executable: bits 0, 3 or 6 are set:
; that means, 'AND' with 1+8+64=73 results in a nonzero-value
; note: there is no distinction between user's, group's and other's permissions
; (as the real GNU-ls does not)
((not (zero? (bitwise-and (file-info:mode info) 73)))
(write-char #\* port))
((eq? (file-info:type info) 'socket)
(write-char #\= port))
((eq? (file-info:type info) 'fifo)
(write-char #\| port)))
#t)))
(define (display-permissions info port)
(case (file-info:type info)
((directory)
(write-char #\d port))
((symlink)
(write-char #\l port))
((fifo)
(write-char #\p port))
(else
(write-char #\- port)))
(let ((mode (file-info:mode info))
(bit 8))
(for-each
(lambda (id)
(if (not (zero? (bitwise-and (arithmetic-shift 1 bit)
mode)))
(write-char id port)
(write-char #\- port))
(set! bit (- bit 1)))
'(#\r #\w #\x #\r #\w #\x #\r #\w #\x))))
(define (display-decimal-justified number width port)
(display-justified (number->string number) width port))
(define (display-justified string width port)
(let ((length (string-length string)))
(if (< length width)
(display-spaces (- width length) port))
(display string port)))
(define (display-padded string width port)
(let ((length (string-length string)))
(display string port)
(if (< length width)
(display-spaces (- width length) port))))
(define (display-spaces number port)
(do ((i 0 (+ 1 i)))
((= i number))
(write-char #\space port)))
;; Convert Unix-style arguments to flags suitable for LS.
(define (arguments->ls-flags args)
(let loop ((args args) (flags '()))
(if (null? args)
flags
(cond
((argument->ls-flags (car args))
=> (lambda (new-flags)
(loop (cdr args) (append new-flags flags))))
(else #f)))))
(define (argument->ls-flags arg)
(let ((arg (if (symbol? arg)
(symbol->string arg)
arg)))
(if (or (string=? "" arg)
(not (char=? #\- (string-ref arg 0))))
#f
(let loop ((chars (cdr (string->list arg))) (flags '()))
(cond
((null? chars)
flags)
((char->flag (car chars))
=> (lambda (flag)
(loop (cdr chars) (cons flag flags))))
(else #f))))))
(define (char->flag char)
(case char
((#\a) 'all)
((#\R) 'recursive)
((#\l) 'long)
((#\d) 'directory)
((#\F) 'flag)
((#\C) 'columns)
(else #f)))
(define (optional maybe-arg default-exp)
(cond
((null? maybe-arg) default-exp)
((null? (cdr maybe-arg)) (car maybe-arg))
(else (error "too many optional arguments" maybe-arg))))
(define (ls-newline port)
(if (fluid ls-crlf?)
(write-crlf port)
(newline port)))

393
scheme/lib/netrc.scm Normal file
View File

@ -0,0 +1,393 @@
;;; netrc.scm -- parse authentication information contained in ~/.netrc
;;
;; $Id: netrc.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;;; Overview =====================================================
;;
;; On Unix systems the ~/.netrc file (in the user's home directory)
;; may contain information allowing automatic login to remote hosts.
;; The format of the file is defined in the ftp(1) manual page.
;; Example lines are
;;
;; machine ondine.cict.fr login marsden password secret
;; default login anonymous password user@site
;;
;; The ~/.netrc file should be protected by appropriate permissions,
;; and (like /usr/bin/ftp) this library will refuse to read the file if
;; it is badly protected. (unlike /usr/bin/ftp this library will always
;; refuse to read the file -- /usr/bin/ftp refuses it only if the password
;; is given for a non-default account). Appropriate permissions are set
;; if only the user has permissions on the file.
;;
;; Note following restrictions / differences:
;; * The macdef statement (defining macros) is not supported.
;; * The settings for one machine must be on a single line.
;; * The is no error proof while reading the file.
;; * default need not be the last line of the netrc-file
;;; Entry points =======================================================
;;
;; What you probably want, is to read out the default netrc-file. Do the
;; following:
;;
;; (let ((netrc-record (netrc:parse)))
;; (netrc:lookup netrc-record "name of the machine"))
;;
;; and you will receive three values: login-name, password and account-name.
;; If you only want the login-name or the password, use netrc:lookup-login
;; or netrc:lookup-password resp.
;;
;; You will get either the login / password for the specified machine,
;; or a default login / password if the machine is unknown.
;;
;;
;; (user-mail-address) -> string
;; Calculate the user's email address, as per the Emacs function of
;; the same name. Will take into account the environment variable
;; REPLYTO, if set. Otherwise the mail-address will look like
;; user@hostname.
;;
;; (netrc:parse [filename [fallback-password [fallback-login]]])
;; -> netrc-record
;; * parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures.
;; * FILENAME defaults to "~/.netrc"
;; FALLBACK-PASSWORD defaults to the result of (user-mail-address)
;; FALLBACK-LOGIN defaults to "anonymous"
;; * if the netrc file does not provide a default password or a default
;; login (stated by the "default" statement), FALLBACK-PASSWORD and
;; FALLBACK-LOGIN will be used as default password or login, respectively.
;; (thus, user-mail-address is only called if the netrc file does not
;; contain a default specification)
;; * if the netrc file does not exist, a netrc-record filled with
;; default values is returned.
;; * if the netrc file does not have the correct permissions, a message is
;; printed to current error port and a netrc-record filled with default
;; values is returned.
;;
;; (netrc:try-parse filename fallback-password fallback-login) -> netrc-record
;; parses the netrc file and returns a netrc-record, containing all
;; necessary information for the following procedures.
;; if there is no file called FILENAME, the according error will be raised
;; if the specified file does not have the correct permissions set,
;; a netrc-refuse-warning will be signalled.
;; so if you don't like the error handling of netrc:parse, use
;; netrc:try-parse and catch the signalled conditions.
;;
;; (netrc:lookup netrc-record machine [default?]) -> string x string x string
;; Return the login,password,account information for MACHINE
;; specified by the netrc file.
;; If DEFAULT? is #t, default values are returned if no such
;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f
;; is returned
;;
;; (netrc:lookup-password netrc-record machine [default?]) -> string
;; Return the password information for MACHINE specified by the
;; netrc file.
;; If DEFAULT? is #t, the default password is returned if no such
;; MACHINE is specified. Otherwise, #f is returned.
;;
;; (netrc:lookup-login netrc-record machine [default?]) -> string
;; Return the login information for MACHINE specified by the
;; netrc file.
;; If DEFAULT? is #t, the default login is returned if no such
;; MACHINE is specified. Otherwise, #f is returned.
;;
;; (netrc:default-login netrc-record) -> string
;; Return the default login specified by the netrc file or "anonymous"
;;
;; (netrc:default-password netrc-record) -> string
;; Return the default password specified by the netrc file or
;; the mail-addres (result of (user-mail-address))
;;; Related work ========================================================
;;
;; * Graham Barr has written a similar library for Perl, called
;; Netrc.pm
;;
;; * ange-ftp.el (transparent remote file access for Emacs) parses the
;; user's netrc file
;;; Portability ==================================================
;;
;; getenv, scsh file primitives, regexp code, format
;; define-record, ecm-utilities
;;; Desirable things =============================================
;;
;; * Remove restrictions (as stated in 'Overview') and behave like
;; /usr/bin/ftp behaves
;; * perhaps: adding case-insensitivity (for host names)
;; * perhaps: better record-disclosers for netrc-entry- and netrc-records
; return the user's mail address, either specified by the environment
; variable REPLYTO or "user@hostname".
(define (user-mail-address)
(or (getenv "REPLYTO")
(string-append (user-login-name) "@" (system-fqdn))))
; looks up the desired machine in a netrc-record
; if the machine is found in the entries-section
; following three values are returned: login, password and account
; if the machine is not found in the entries-section
; the behavior depends on lookup-default? which defaults to #t:
; if lookup-default? is #t
; following three values are returned: default-login default-password #f
; otherwise #f #f #f is returned.
(define (netrc:lookup netrc-record machine . lookup-default?)
(let-optionals lookup-default?
((lookup-default? #t))
(let ((record (find-record netrc-record machine)))
(if record
(values (netrc-entry:login record)
(netrc-entry:password record)
(netrc-entry:account record))
(if lookup-default?
(values (netrc:default-login netrc-record)
(netrc:default-password netrc-record)
#f)
(values #f #f #f))))))
; does the same as netrc:lookup, but returns only the password (or #f)
(define (netrc:lookup-password netrc-record machine . lookup-default?)
(let-optionals lookup-default?
((lookup-default? #t))
(let ((record (find-record netrc-record machine)))
(if record
(netrc-entry:password record)
(and lookup-default?
(netrc:default-password netrc-record))))))
; does the same as netrc:lookup, but returns only the login (or #f)
(define (netrc:lookup-login netrc-record machine . lookup-default?)
(let-optionals lookup-default?
((lookup-default? #t))
(let ((record (find-record netrc-record machine)))
(if record
(netrc-entry:login record)
(and lookup-default?
(netrc:default-login netrc-record))))))
; does the work for netrc:parse
; file-name has to be resolved
(define (netrc:try-parse file-name default-password default-login)
(netrc:check-permissions file-name)
(let ((fd (open-input-file file-name))
(netrc-record (make-netrc '() default-password default-login file-name)))
(for-each-line (parse-line netrc-record) fd)))
; parses the netrc-file
; expected arguments: filename default-password default-login
; filename: filename of the .netrc-file (defaults to ~/.netrc)
; default-password: default password for any not specified machine
; defaults to (user-mail-address)
; default password in netrc-file overwrites this setting
; default-login: default login name for any not specified machine
; defaults to "anonymous"
; default login in netrc-file overwrites this setting
; * (default-login is expected after default-password as users usually want
; to change the default-password (to something else than their mail-address)
; rather than the login-name)(define (netrc:parse . args)
; * if the given file does not exist or it has the wrong permissions,
; than a default netrc-record is returned
; * if you don't want expected errors to be captured, use netrc:try-parse;
; note that you have to resolve the file-name on your own
(define-condition-type 'netrc-refuse '(warning))
(define netrc-refuse? (condition-predicate 'netrc-refuse))
(define (netrc:parse . args)
(let-optionals
args ((file-name "~/.netrc")
(default-password #f) ; both ...
(default-login #f)) ; ... are set if netrc-file does
; not provide default-values
(let* ((file-name (resolve-file-name file-name))
(local-default-login (lambda () "anonymous"))
(local-default-password (lambda () (user-mail-address)))
(local-default-netrc-record
(lambda ()
(make-netrc '()
(or default-login (local-default-login))
(or default-password (local-default-password))
#f))))
; i know, this double-handler sucks; has anyone a better idea?
(call-with-current-continuation
(lambda (exit)
(with-handler
(lambda (error more)
(if (netrc-refuse? error)
(format (current-error-port)
"netrc: Warning: ~a~%"
(car (condition-stuff error)))
(format (current-error-port)
"netrc: Warning: Unexpected error encountered: ~s~%"
error))
(exit (local-default-netrc-record)))
(lambda ()
(with-errno-handler*
(lambda (errno packet)
(if (= errno errno/noent)
(format (current-error-port)
"netrc: Warning: no such file or directory: ~a~%"
file-name)
(format (current-error-port)
"netrc: Warning: Error accessing file ~s~%"
file-name))
(exit (local-default-netrc-record)))
(lambda ()
(let ((netrc-record
(netrc:try-parse file-name default-password default-login)))
; If we get a netrc-record, we return it after
; checking default login and default password settings.
; Otherwise, we return the default record with
; file-name stored.
; This is sub-optimal, as we may throw away badly
; structured .netrc-files silently. We need an error
; checking mechanism.
(if (netrc? netrc-record)
(begin
(if (eq? (netrc:default-login netrc-record) #f)
(set-netrc:default-login (local-default-login)))
(if (eq? (netrc:default-password netrc-record) #f)
(set-netrc:default-password (local-default-password)))
netrc-record)
(let ((default-netrc-record (local-default-netrc-record)))
(set-netrc:file-name default-netrc-record file-name)
default-netrc-record))))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nothing exported below
;; except
;; netrc:default-password
;; netrc:default-login
(define-record netrc-entry
machine
login
password
account)
(define-record netrc
entries ; list of netrc-entrys
default-login ; default-values (either library-default or netrc-file-default)
default-password
file-name) ; debug-purpose
(define-record-discloser type/netrc-entry
(lambda (netrc-entry)
(list 'netrc-entry))) ; perhaps something else later on
(define-record-discloser type/netrc
(lambda (netrc)
(list 'netrc))) ; perhaps something else later on
; finds a record in the entries-list of a netrc-record
; matching the given machine
; returns the netrc-entry-record if found, otherwise #f
(define (find-record netrc-record machine)
(find-first (lambda (rec)
(and (equal? (netrc-entry:machine rec) machine)
rec))
(netrc:entries netrc-record)))
;; raise error if any permissions are set for group or others.
(define (netrc:check-permissions file-name)
(let ((perms (- (file-mode file-name) 32768)))
(if (positive? (bitwise-and #b000111111 perms))
(signal 'netrc-refuse
(format #f
"Not parsing ~s (netrc file); dangerous permissions."
file-name)))))
; tries to match target on line and returns the first group,
; or #f if there is no match
(define (try-match target line)
(let ((match (string-match target line)))
(and match
(match:substring match 1))))
; parses the default line of the netrc-file
(define (parse-default netrc-record line)
(let ((login (try-match "login[ \t]+([^ \t]+)" line))
(password (try-match "password[ \t]+([^ \t]+)" line)))
(if login
(set-netrc:default-login netrc-record login))
(if password
(set-netrc:default-password netrc-record password))
netrc-record))
; parses a line of the netrc-file
(define (parse-line netrc-record)
(lambda (line)
(cond ((string-match "default" line)
(parse-default netrc-record line))
(else
(let ((machine (try-match "machine[ \t]+([^ \t]+)" line))
(login (try-match "login[ \t]+([^ \t]+)" line))
(password (try-match "password[ \t]+([^ \t]+)" line))
(account (try-match "account[ \t]+([^ \t]+)" line)))
(if (or machine login password account)
(add netrc-record machine login password account)
netrc-record)))))) ; return record on empty / wrong lines
; (This is a workaround. we should give a warning on malicious .netrc
; files. As we do not have an error checking system installed yet, we
; skip these lines silently.)
; adds machine login password account stored in a netrc-entry-record
; to the entries-list of a netrc-record
(define (add netrc-record machine login password account)
(set-netrc:entries netrc-record
(cons (make-netrc-entry machine login password account)
(netrc:entries netrc-record)))
netrc-record)
;; for testing
(define (netrc:dump netrc-record)
(format #t "~%--- Dumping ~s contents ---" (netrc:file-name netrc-record))
(for-each (lambda (rec)
(format #t "~% machine ~a login ~a password ~a account ~a"
(netrc-entry:machine rec)
(netrc-entry:login rec)
(netrc-entry:password rec)
(netrc-entry:account rec)))
(netrc:entries netrc-record))
(format #t "~% default login: ~s" (netrc:default-login netrc-record))
(format #t "~% default password: ~s" (netrc:default-password netrc-record))
(format #t "~%--- End of ~s contents ---~%" (netrc:file-name netrc-record)))
; runs proc for each line of fd (line is argument to proc)
; returns either nothing, if the fd had no line
; or the value returned by proc called on the last line
(define (for-each-line proc fd)
(let ((line (read-line fd)))
(if (not (eof-object? line))
(let loop ((last-result (proc line)))
(let ((line (read-line fd)))
(if (not (eof-object? line))
(loop (proc line))
last-result))))))
; finds first element in l for which pred doesn't return #f
; returns either #f (no such element found)
; or the result of the last call to pred
(define (find-first pred l)
(if (null? l) #f
(or (pred (car l))
(find-first pred (cdr l)))))
;; EOF

6
scheme/lib/nettime-obsolete.scm Normal file
View File

@ -0,0 +1,6 @@
; maps obsolete nettime-procedure names to new nettime procedure names
; by Andreas Bernauer (2002)
(define net:time net-time)
(define net:daytime net-daytime)

76
scheme/lib/nettime.scm Normal file
View File

@ -0,0 +1,76 @@
;;; nettime.scm -- obtain the time on remote machines
;;
;; $Id: nettime.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;;; Overview ========================================================
;;
;; Most Unix hosts provide a Daytime service which sends the current
;; date and time as a human-readable character string. The daytime
;; service is typically served on port 13 as both TCP and UDP.
;;
;; The Time protocol provides a site-independent, machine readable
;; date and time. A "time" consists of the number of seconds since
;; midnight on 1st January 1900. The Time service is typically served
;; on port 37 as TCP and UDP. The idea is that you can confirm your
;; system's idea of the time by polling several independent sites on
;; the network.
;;; Related work ======================================================
;;
;; * Time.pm is a Perl module by Graham Barr
;; * rfc868 describes the Time protocol
;; * rfc867 describes the Daytime protocol in all its glory
;; * for a genuinely useful protocol look at the Network Time Protocol
;; defined in rfc1305, which allows for the synchronization of clocks
;; on networked computers.
;; args host protocol, where host may be an IP number or a fqdn. we
;; subtract 70 years' worth of seconds at the end, since the time
;; protocol returns the number of seconds since 1900, whereas Unix
;; time is since 1970.
(define (net-time host tcp/udp)
(let* ((hst-info (host-info host))
(srvc-info (service-info "time" "tcp"))
(sock (socket-connect protocol-family/internet
tcp/udp
(host-info:name hst-info)
(service-info:port srvc-info)))
(result (read-integer (socket:inport sock))))
(close-socket sock)
(- result 2208988800)))
(define (net-daytime host tcp/udp)
(let* ((hst-info (host-info host))
(srvc-info (service-info "daytime" "tcp"))
(sock (socket-connect protocol-family/internet
tcp/udp
(host-info:name hst-info)
(service-info:port srvc-info)))
(result (read-string 20 (socket:inport sock))))
(close-socket sock)
result))
;; read 4 bytes from fd and build an integer from them
(define (read-integer fd)
(let loop ((accum 0)
(remaining 4))
(if (zero? remaining)
accum
(loop (+ (arithmetic-shift accum 8) (read-byte fd))
(- remaining 1)))))
;; what about EOF??
(define (read-byte fd)
(char->ascii (read-char fd)))
;; EOF

67
scheme/lib/parse-forms.scm Normal file
View File

@ -0,0 +1,67 @@
;;; Code to parse information submitted from HTML forms. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html
;;; Imports and non-R4RS'isms
;;; string-index (string srfi)
;;; let-optionals (let-opt package)
;;; receive (Multiple-value return)
;;; unescape-uri
;;; map-string (strings package)
;;; ? (cond)
;;; About HTML forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; The form's field data are turned into a single string, of the form
;;; The form's field data are turned into a single string, of the form
;;; name=val&name=val
;;; where the <name> and <val> parts are URI encoded to hide their
;;; &, =, and + chars, among other things. After URI encoding, the
;;; space chars are converted to + chars, just for fun. It is important
;;; to encode the spaces this way, because the perfectly general %xx escape
;;; mechanism might be insufficiently confusing. This variant encoding is
;;; called "form-url encoding."
;;;
;;; If the form's method is POST,
;;; Browser sends the form's field data in the entity block, e.g.,
;;; "button=on&ans=yes". The request's Content-type: is application/
;;; x-www-form-urlencoded, and the request's Content-length: is the
;;; number of bytes in the form data.
;;;
;;; If the form's method is GET,
;;; Browser sends the form's field data in the URL's <search> part.
;;; (So the server will pass to the CGI script as $QUERY_STRING,
;;; and perhaps also on in argv[]).
;;;
;;; In either case, the data is "form-url encoded" (as described above).
;;; Form-query parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Parse "foo=x&bar=y" into (("foo" . "x") ("bar" . "y"))
;;; Substrings are plus-decoded and then URI-decoded. This implementation is
;;; slightly sleazy as it will successfully parse a string like "a&b=c&d=f"
;;; into (("a&b" . "c") ("d" . "f")) without a complaint.
(define (parse-html-form-query q)
(let ((qlen (string-length q)))
(let recur ((i 0))
(cond
((>= i qlen) '())
((string-index q #\= i) =>
(lambda (j)
(let ((k (or (string-index q #\& j) qlen)))
(cons (cons (unescape-uri+ q i j)
(unescape-uri+ q (+ j 1) k))
(recur (+ k 1))))))
(else '()))))) ; BOGUS STRING -- Issue a warning.
;;; Map plus characters to spaces, then do URI decoding.
(define (unescape-uri+ s . maybe-start/end)
(let-optionals maybe-start/end ((start 0)
(end (string-length s)))
(unescape-uri (string-map (lambda (c) (if (char=? c #\+) #\space c))
(if (and (zero? start)
(= end (string-length s)))
s ; Gratuitous optimisation.
(substring s start end))))))

12
scheme/lib/pop3-obsolete.scm Normal file
View File

@ -0,0 +1,12 @@
; maps obsolete pop3-procedure names to new pop3 procedure names
; by Andreas Bernauer (2002)
(define pop3:connect pop3-connect)
(define pop3:login pop3-login)
(define pop3:stat pop3-stat)
(define pop3:get pop3-get)
(define pop3:headers pop3-headers)
(define pop3:last pop3-last)
(define pop3:delete pop3-delete)
(define pop3:reset pop3-reset)
(define pop3:quit pop3-quit)

351
scheme/lib/pop3.scm Normal file
View File

@ -0,0 +1,351 @@
;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
;;
;; $Id: pop3.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;;; Overview ==============================================================
;;
;; The POP3 protocol allows access to email on a maildrop server. It
;; is often used in configurations where users connect from a client
;; machine which doesn't have a permanent network connection or isn't
;; always turned on, situations which make local SMTP delivery
;; impossible. It is the most common form of email access provided by
;; Internet Service Providers.
;;
;; Two types of authentication are commonly used. The first, most
;; basic type involves sending a user's password in clear over the
;; network, and should be avoided. Unfortunately many POP3 clients
;; only implement this basic authentication. The digest authentication
;; system involves the server sending the client a "challenge" token;
;; the client encodes this token with the pass phrase and sends the
;; coded information to the server. This method avoids sending
;; sensitive information over the network.
;;
;; Once connected, a client may request information about the number
;; and size of the messages waiting on the server, download selected
;; messages (either their headers or the entire content), and delete
;; selected messages.
;;; Entry points =======================================================
;;
;; (pop3-connect [host logfile]) -> connection
;; Connect to the maildrop server named HOST. Optionally log the
;; conversation with the server to LOGFILE, which will be appended
;; to if it exists, and created otherwise. The environment variable
;; MAILHOST, if set, will override the value of HOST.
;;
;; (pop3-login connection [login password]) -> status
;; Log in to the mailhost. If a login and password are not
;; provided, they are first searched for in the user's ~/.netrc
;; file. USER/PASS authentication will be tried first, and if this
;; fails, APOP authentication will be tried.
;;
;; (pop3-login/APOP connection login password) -> status
;; Log in to the mailhost using APOP authentication.
;;
;; (pop3-stat connection) -> integer x integer
;; Return the number of messages and the number of bytes waiting in
;; the maildrop.
;;
;; (pop3-get connection msgid) -> status
;; Download message number MSGID from the mailhost. MSGID must be
;; positive and less than the number of messages returned by the
;; pop3-stat call. The message contents are sent to
;; (current-output-port).
;;
;; (pop3-headers connection msgid) -> status
;; Download the headers of message number MSGID. The data is sent
;; to (current-output-port).
;;
;; (pop3-last connection) -> integer
;; Return the highest accessed message-id number for the current
;; session. This isn't in the RFC, but seems to be supported by
;; several servers.
;;
;; (pop3-delete connection msgid) -> status
;; Mark message number MSGID for deletion. The message will not be
;; deleted until the client logs out.
;;
;; (pop3-reset connection) -> status
;; Any messages which have been marked for deletion are unmarked.
;;
;; (pop3-quit connection) -> status
;; Close the connection with the mailhost.
;;; Portability ======================================================
;;
;; define-record
;; socket, regexp
;; signals/handlers
;;; Related work =====================================================
;;
;; * Emacs is distributed with a C program called movemail which can
;; be compiled with support for the POP protocol. There is also an
;; Emacs Lisp library called pop3.el by Richard Pieri which includes
;; APOP support.
;;
;; * Shriram Krishnamurth has written a POP3 library for MzScheme (as
;; well as support for the NNTP protocol, for SMTP, ...).
;;
;; * Siod (a small-footprint Scheme implementation by George Carette)
;; includes support for the POP3 protocol.
;;
;; * rfc1939 describes the POP3 protocol.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Communication is initiated by the client. The server responds to
;; each request with a status indicator and an explanatory message.
;; The client starts off by opening a connection to a well known port
;; on the server machine (typically TCP 110, or 109 on some broken
;; systems). Messages sent to the server are of the form
;;
;; CMD [ <space> arg ] <CR> <LF>
;;
;; Replies from the server are of the form
;;
;; status [ <space> Informative message ] <CR> <LF>
;;
;; where status is either "+OK" or "-ERR". If the server is sending
;; data (the contents of a message for example), it marks the end of
;; the data by a line consisting only of a decimal point (thus the
;; bytes to look out for are <CR><LF>.<CR><LF>. Any lines in the data
;; starting with a . have an additional . added to the beginning, to
;; avoid the client thinking that the line marks the end of the
;; message. The client should therefore replace double decimal points
;; at the beginning of a line by a single decimal point.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;: [host x logfile] -> connection
(define (pop3-connect . args)
(let* ((host (or (getenv "MAILHOST")
(safe-first args)))
(logfile (safe-second args))
(LOG (and logfile
(open-output-file logfile
(if (file-exists? logfile)
(bitwise-ior open/write open/append)
(bitwise-ior open/write open/create))
#o600)))
(hst-info (host-info host))
(hostname (host-info:name hst-info))
(srvc-info (service-info "pop3" "tcp"))
(sock (socket-connect protocol-family/internet
socket-type/stream
hostname
(service-info:port srvc-info)))
(connection (make-pop3-connection hostname
sock
LOG "" "" #f #f)))
(pop3-log connection
(format #f "~%-- ~a: opened POP3 connection to ~a"
;; (date->string (date))
"Dummy date" ; (format-time-zone) is broken in v0.5.1
hostname))
;; read the challenge the server sends in its welcome banner
(let* ((banner (pop3-read-response connection))
(match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
(challenge (and match (match:substring match 1))))
(set-pop3-connection:challenge connection challenge))
connection))
;; first try standard USER/PASS authentication, and switch to APOP
;; authentication if the server prefers.
;;: [string x string] -> status
(define (pop3-login connection . args)
(let* ((netrc (and (< (length args) 2) (netrc:parse)))
(login (or (safe-first args)
(netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
(call-error "must provide a login" pop3-login args)))
(password (or (safe-second args)
(netrc:lookup-password netrc (pop3-connection:host-name connection) #f)
(call-error "must provide a password" pop3-login args))))
(with-handler
(lambda (result punt)
(if (-ERR? result)
(if (pop3-connection:challenge connection)
(pop3-login/APOP connection login password)
(error "login failed"))))
(lambda ()
(pop3-send-command connection (format #f "USER ~a" login))
(pop3-send-command connection (format #f "PASS ~a" password))
(set-pop3-connection:login connection login)
(set-pop3-connection:password connection password)
(set-pop3-connection:state connection 'connected)))))
;; Login to the server using APOP authentication (no cleartext
;; passwords are sent over the network). The server appends a token to
;; its welcome message, which is built from the server's fully
;; qualified domain name and a unique serial number. The client
;; concatenates this token and the pass phrase and applies the MD5
;; digest algorithm (a one-way hash) to produce a digest. The user
;; name and the digest are sent to the server to authenticate the
;; user. The following example comes from the RFC:
;;
;; S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us>
;; C: APOP mrose c4c9334bac560ecc979e58001b3e22fb
;; S: +OK maildrop has 1 message (369 octets)
;;
;; In this example, the shared secret is the string `tan-
;; staaf'. Hence, the MD5 algorithm is applied to the string
;;
;; <1896.697170952@dbc.mtview.ca.us>tanstaaf
;;
;; which produces a digest value of
;;
;; c4c9334bac560ecc979e58001b3e22fb
;;
;;: connection x string x string -> status
(define (pop3-login/APOP connection login password)
(let* ((key (string-append (pop3-connection:challenge connection)
password))
(digest (md5-digest key))
(status (pop3-send-command connection
(format #f "APOP ~a ~a" login digest))))
(set-pop3-connection:login connection login)
(set-pop3-connection:password connection password)
(set-pop3-connection:state connection 'connected)
status))
;; return number of messages and number of bytes waiting at the maildrop
;;: connection -> integer x integer
(define (pop3-stat connection)
(pop3-check-transaction-state connection 'pop3-stat)
(let* ((response (pop3-send-command connection "STAT"))
(match (regexp-search (rx (posix-string "([0-9]+) ([0-9]+)")) response)))
(values (string->number (match:substring match 1))
(string->number (match:substring match 2)))))
;; dump the message number MSGID to (current-output-port)
;;: connection x integer -> status
(define (pop3-get connection msgid)
(pop3-check-transaction-state connection 'pop3-get)
(let ((status (pop3-send-command connection (format #f "RETR ~a" msgid))))
(pop3-dump (socket:inport (pop3-connection:command-socket connection)))
status))
;;: connection x integer -> status
(define (pop3-headers connection msgid)
(pop3-check-transaction-state connection 'pop3-headers)
(let ((status (pop3-send-command connection (format #f "TOP ~a 0" msgid))))
(pop3-dump (socket:inport (pop3-connection:command-socket connection)))
status))
;; Return highest accessed message-id number for the session. This
;; ain't in the RFC, but seems to be supported by several servers.
;;: connection -> integer
(define (pop3-last connection)
(pop3-check-transaction-state connection 'pop3-last)
(let ((response (pop3-send-command connection "LAST")))
(string->number (car ((infix-splitter) response)))))
;; mark the message number MSGID for deletion. Note that the messages
;; are not truly deleted until the QUIT command is sent, and messages
;; can be undeleted using the RSET command.
;;: connection x integer -> status
(define (pop3-delete connection msgid)
(pop3-check-transaction-state connection 'pop3-delete)
(pop3-send-command connection (format #f "DELE ~a" msgid)))
;; any messages which have been marked for deletion are unmarked
;;: connection -> status
(define (pop3-reset connection)
(pop3-check-transaction-state connection 'pop3-reset)
(pop3-send-command connection "RSET"))
;;: connection -> status
(define (pop3-quit connection)
(pop3-check-transaction-state connection 'pop3-quit)
(let ((status (pop3-send-command connection "QUIT")))
(close-socket (pop3-connection:command-socket connection))
status))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Nothing exported below.
(define-record pop3-connection
host-name
command-socket
logfd
login
password
challenge
state)
;; cf /usr/local/src/scheme48-0.49/scheme/rts/condition.scm
(define-condition-type '-ERR '(error))
(define -ERR? (condition-predicate '-ERR))
(define (pop3-check-transaction-state connection caller)
(if (not (eq? (pop3-connection:state connection) 'connected))
(call-error "not in transaction state" caller)))
(define (pop3-read-response connection)
(let* ((sock (pop3-connection:command-socket connection))
(IN (socket:inport sock))
(line (read-line IN)))
(pop3-log connection (format #f "-> ~a" line))
line))
;; this could perhaps be improved
(define (pop3-handle-response response command)
(let ((match (regexp-search (rx (posix-string "^\\+OK(.*)")) response)))
(if match
(match:substring match 1)
(let ((match2 (regexp-search (rx (posix-string "^-ERR(.*)")) response)))
(if match2
(signal '-ERR (match:substring match2 1) command)
(signal '-ERR response command))))))
(define (pop3-log connection line)
(let ((LOG (pop3-connection:logfd connection)))
(and LOG
(write-string line LOG)
(write-string "\n" LOG)
(force-output LOG))))
(define (pop3-send-command connection command)
(let* ((sock (pop3-connection:command-socket connection))
(OUT (socket:outport sock)))
(write-string command OUT)
(write-crlf OUT)
(pop3-log connection (format #f "<- ~a" command))
(pop3-handle-response (pop3-read-response connection) command)))
;; who will write this in Scheme?
(define (md5-digest str)
(car (run/strings (md5sum) (<< ,str))))
; the name of the program differs among the distributions
; e.g. in FreeBSD it is called md5
(define (pop3-dump fd)
(let loop ((line (read-line fd)))
(cond ((and (not (eof-object? line))
(not (equal? line ".\r")))
(and (eq? 0 (string-index line #\.)) ; fix byte-stuffed lines
(eq? 1 (string-index line #\. 1))
(set! line (substring line 1 (string-length line))))
(write-string line)
(newline)
(loop (read-line fd))))))
;; EOF

58
scheme/lib/rate-limit.scm Normal file
View File

@ -0,0 +1,58 @@
;;; Rate limiting -*- Scheme -*-
;;; Copyright (c) 2002 by Mike Sperber.
(define-record-type rate-limiter :rate-limiter
(really-make-rate-limiter simultaneous-requests
access-lock
block-lock
current-requests)
rate-limiter?
(simultaneous-requests rate-limiter-simultaneous-requests)
(access-lock rate-limiter-access-lock)
(block-lock rate-limiter-block-lock)
(current-requests rate-limiter-current-requests-unsafe
set-rate-limiter-current-requests!))
(define (make-rate-limiter simultaneous-requests)
(really-make-rate-limiter simultaneous-requests
(make-lock)
(make-lock)
0))
(define (rate-limit-block rate-limiter)
(obtain-lock (rate-limiter-block-lock rate-limiter)))
(define (rate-limit-open rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(+ 1 (rate-limiter-current-requests-unsafe rate-limiter))))
(set-rate-limiter-current-requests! rate-limiter
current-requests)
(if (>= current-requests
(rate-limiter-simultaneous-requests rate-limiter))
(maybe-obtain-lock (rate-limiter-block-lock rate-limiter))
(release-lock (rate-limiter-block-lock rate-limiter))))
(release-lock (rate-limiter-access-lock rate-limiter)))
(define (rate-limit-close rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(- (rate-limiter-current-requests-unsafe rate-limiter) 1)))
(if (negative? current-requests)
(error "rate-limiter: too many close operations"
rate-limiter))
(set-rate-limiter-current-requests! rate-limiter
current-requests)
(if (= current-requests
(- (rate-limiter-simultaneous-requests rate-limiter)
1))
;; we just came back into range
(release-lock (rate-limiter-block-lock rate-limiter))))
(release-lock (rate-limiter-access-lock rate-limiter)))
(define (rate-limiter-current-requests rate-limiter)
(obtain-lock (rate-limiter-access-lock rate-limiter))
(let ((current-requests
(rate-limiter-current-requests-unsafe rate-limiter)))
(release-lock (rate-limiter-access-lock rate-limiter))
current-requests))

219
scheme/lib/rfc822.scm Normal file
View File

@ -0,0 +1,219 @@
;;; RFC 822 field-parsing code -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; <shivers@lcs.mit.edu>
;;;
;;; Imports and non-R4RS'isms
;;; string conversions
;;; read-crlf-line
;;; let-optionals, :optional
;;; receive values (MV return)
;;; "\r\n" in string for cr/lf
;;; ascii->char (defining the tab char)
;;; index
;;; string-join (reassembling body lines)
;;; error
;;; ? (COND)
;;; RFC 822 is the "Standard for the format of ARPA Internet text messages"
;;; -- the document that essentially tells how the fields in email headers
;;; (e.g., the Subject: and To: fields) are formatted. This code is for
;;; parsing these headers. Here are two pointers to the document:
;;; Emacs/ange /ftp@ftp.internic.net:/rfc/rfc822.txt
;;; URL ftp://ftp.internic.net/rfc/rfc822.txt
;;; RFC 822 parsing is useful in other contexts as well -- the HTTP protocol
;;; uses it, and it tends to pop up here and there.
;;;
;;; RFC 822 header syntax has two levels: the general syntax for headers,
;;; and the syntax for specific headers. For example, once you have figured
;;; out which chunk of text is the To: line, there are more rules telling
;;; how to split the To: line up into a list of addresses. Another example:
;;; lines with dates, e.g., the Date: header, have a specific syntax for
;;; the time and date.
;;;
;;; This code currently *only* provides routines for parsing the gross
;;; structure -- splitting the message header into its distinct fields.
;;; It would be nice to provide the finer-detail parsers, too. You do it.
;;; -Olin
;;; A note on line-terminators:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Line-terminating sequences are always a drag, because there's no agreement
;;; on them -- the Net protocols and DOS use cr/lf; Unix uses lf; the Mac
;;; uses cr. One one hand, you'd like to use the code for all of the above,
;;; on the other, you'd also like to use the code for strict applications
;;; that need definitely not to recognise bare cr's or lf's as terminators.
;;;
;;; RFC 822 requires a cr/lf (carriage-return/line-feed) pair to terminate
;;; lines of text. On the other hand, careful perusal of the text shows up
;;; some ambiguities (there are maybe three or four of these, and I'm too
;;; lazy to write them all down). Furthermore, it is an unfortunate fact
;;; that many Unix apps separate lines of RFC 822 text with simple linefeeds
;;; (e.g., messages kept in /usr/spool/mail). As a result, this code takes a
;;; broad-minded view of line-terminators: lines can be terminated by either
;;; cr/lf or just lf, and either terminating sequence is trimmed.
;;;
;;; If you need stricter parsing, you can call the lower-level procedure
;;; %READ-RFC-822-FIELD and %READ-RFC822-HEADERS procs. They take the
;;; read-line procedure as an extra parameter. This means that you can
;;; pass in a procedure that recognises only cr/lf's, or only cr's (for a
;;; Mac app, perhaps), and you can determine whether or not the terminators
;;; get trimmed. However, your read-line procedure must indicate the
;;; header-terminating empty line by returning *either* the empty string or
;;; the two-char string cr/lf (or the EOF object).
;;; (read-rfc822-field [port])
;;; (%read-rfc822-field read-line port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read one field from the port, and return two values [NAME BODY]:
;;; - NAME Symbol such as 'subject or 'to. The field name is converted
;;; to a symbol using the Scheme implementation's preferred
;;; case. If the implementation reads symbols in a case-sensitive
;;; fashion (e.g., scsh), lowercase is used. This means you can
;;; compare these symbols to quoted constants using EQ?. When
;;; printing these field names out, it looks best if you capitalise
;;; them with (CAPITALIZE-STRING (SYMBOL->STRING FIELD-NAME)).
;;; - BODY List of strings which are the field's body, e.g.
;;; ("shivers@lcs.mit.edu"). Each list element is one line
;;; from the field's body, so if the field spreads out
;;; over three lines, then the body is a list of three
;;; strings. The terminating cr/lf's are trimmed from each
;;; string. A leading space or a leading horizontal tab
;;; is also trimmed, but one and only one.
;;; When there are no more fields -- EOF or a blank line has terminated the
;;; header section -- then the procedure returns [#f #f].
;;;
;;; The %READ-RFC822-FIELD variant allows you to specify your own
;;; read-line procedure. The one used by READ-RFC822-FIELD terminates
;;; lines with either cr/lf or just lf, and it trims the terminator
;;; from the line. Your read-line procedure should trim the terminator
;;; of a line so an empty line is returned just as an empty string.
(define htab (ascii->char 9))
;;; Convert to a symbol using the Scheme implementation's preferred case,
;;; so we can compare these things against quoted constants.
(define string->symbol-pref
(if (char=? #\a (string-ref (symbol->string 'a) 0)) ; Is it #\a or #\A?
(lambda (s) (string->symbol (string-map char-downcase s)))
(lambda (s) (string->symbol (string-map char-upcase s)))))
(define (read-rfc822-field . maybe-port)
(let-optionals maybe-port ((port (current-input-port)))
(%read-rfc822-field read-crlf-line port)))
(define (%read-rfc822-field read-line port)
(let ((line1 (read-line port)))
(if (or (eof-object? line1)
(zero? (string-length line1))
(string=? line1 "\r\n")) ; In case read-line doesn't trim.
(values #f #f) ; Blank line or EOF terminates header text.
(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 :
;;; (read-rfc822-headers [port])
;;; (%read-rfc822-headers read-line port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Read in and parse up a section of text that looks like the header portion
;;; of an RFC 822 message. Return an alist mapping a field name (a symbol
;;; such as 'date or 'subject) to a list of field bodies -- one for
;;; each occurence of the field in the header. So if there are five
;;; "Received-by:" fields in the header, the alist maps 'received-by
;;; to a five element list. Each body is in turn represented by a list
;;; of strings -- one for each line of the field. So a field spread across
;;; three lines would produce a three element body.
;;;
;;; The %READ-RFC822-HEADERS variant allows you to specify your own read-line
;;; procedure. See notes above for reasons why.
(define (read-rfc822-headers . maybe-port)
(let-optionals maybe-port ((port (current-input-port)))
(%read-rfc822-headers read-crlf-line port)))
(define (%read-rfc822-headers read-line port)
(let lp ((alist '()))
(receive (field val) (%read-rfc822-field read-line port)
(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])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Takes a field alist such as is returned by READ-RFC822-HEADERS and
;;; returns an equivalent alist. Each body (string list) in the input alist
;;; is joined into a single list in the output alist. SEPARATOR is the
;;; string used to join these elements together; it defaults to a single
;;; space " ", but can usefully be "\n" or "\r\n".
;;;
;;; To rejoin a single body list, use scsh's STRING-JOIN procedure.
(define (rejoin-header-lines alist . maybe-separator)
(let-optionals maybe-separator ((sep " "))
(map (lambda (entry)
(cons (car entry)
(map (lambda (body) (string-join body sep))
(cdr entry))))
alist)))
;;; Given a set of RFC822 headers like this:
;;; From: shivers
;;; To: ziggy,
;;; newts
;;; To: gjs, tk
;;;
;;; We have the following definitions:
;;; (get-header-all hdrs 'to) -> ((" ziggy," " newts") (" gjs, tk"))
;;; - All entries, or #f
;;; (get-header-lines hdrs 'to) -> (" ziggy," " newts")
;;; - All lines of the first entry, or #f.
;;; (get-header hdrs 'to) -> "ziggy,\n newts"
;;; - First entry, with the lines joined together by newlines.
(define (get-header-all headers name)
(let ((entry (assq name headers)))
(and entry (cdr entry))))
(define (get-header-lines headers name)
(let ((entry (assq name headers)))
(and entry
(pair? entry)
(cadr entry))))
(define (get-header headers name . maybe-sep)
(let ((entry (assq name headers)))
(and entry
(pair? entry)
(string-join (cadr entry)
(:optional maybe-sep "\n")))))
;;; Other desireable functionality
;;; - Unfolding long lines.
;;; - Lexing structured fields.
;;; - Unlexing structured fields into canonical form.
;;; - Parsing and unparsing dates.
;;; - Parsing and unparsing addresses.

606
scheme/lib/smtp.scm Normal file
View File

@ -0,0 +1,606 @@
;;; SMTP client code -*- Scheme -*-
;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers.
;;; <bdc@ai.mit.edu>, <shivers@lcs.mit.edu>
;;;
;;; See rfc821: /ftp@ftp.internic.net:/rfc/rfc821.txt
;;; External dependencies and non-R4RS'isms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; system-name user-login-name (for high-level SENDMAIL proc)
;;; receive values (MV return)
;;; write-string read-string/partial (scsh I/O procs)
;;; force-output
;;; scsh's socket module
;;; :optional
;;; error
;;; read-crlf-line write-crlf
;;; \n \r in strings (Not R5RS)
;;; SMTP protocol procedures tend to return two values:
;;; - CODE The integer SMTP reply code returned by server for the transaction.
;;; - TEXT A list of strings -- the text messages tagged by the code.
;;; The text strings have the initial code numerals and the terminating
;;; cr/lf's stripped. Codes in the range [1,399] are sucess codes; codes
;;; in the range [400,599] are error codes; codes >= 600 are not part
;;; of the official SMTP spec. This module uses codes >= 600 to indicate
;;; extra-protocol errors. There are two of these:
;;; - 600 Server reply could not be parsed.
;;; The server sent back some sort of incomprehensible garbage reply.
;;; - 621 Premature EOF while reading server reply.
;;; The server shut down in the middle of a reply.
;;; A list of the official protocol return codes is appended at the end of
;;; this file.
;;; These little cover functions are trivial packagings of the protocol.
;;; You could write your own to handle, e.g., mailing a message to a list
;;; of addresses.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not
;;; a useful Internet host name. How do we do that?
;;; [Andreas:] I've inserted a way to do this. It works fine on my
;;; system. Does it work on your, too?
;;; (sendmail to-list body [host])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mail message to recipients in list TO-LIST. Message handed off to server
;;; running on HOST; default is the local host. Returns two values: code and
;;; text-list. However, if only problem with message is that some recipients
;;; were rejected, sendmail sends to the rest of the recipients, and the
;;; partial-success return is [700 loser-alist] where loser-alist
;;; is a list whose elements are of the form (loser-recipient code . text) --
;;; that is, for each recipient refused by the server, you get the error
;;; data sent back for that guy. The success check is (< code 400).
;;;
;;; BODY is a string or an input port.
(define (sendmail to-list body . maybe-host)
(call-with-current-continuation
(lambda (bailout)
(let ((local (host-info:name (host-info (system-name))))
(socket (smtp/open (:optional maybe-host "localhost"))))
(receive (code text) (smtp-transactions socket ; Do prologue.
(smtp/helo socket local)
(smtp/mail socket (string-append (user-login-name)
"@" local)))
(if (>= code 400) (values code text) ; error
;; Send over recipients and collect the losers.
(let ((losers (filter-map
(lambda (to)
(receive (code text) (smtp/rcpt socket to)
(and (>= code 400) ; Error
(cond ((>= code 600)
(smtp/quit socket)
(bailout code text))
(else `(,to ,code ,@text))))))
to-list)))
;; Send the message body and wrap things up.
(receive (code text) (smtp-transactions socket
(smtp/data socket body)
(smtp/quit socket))
(if (and (< code 400) (null? losers))
(values code text)
(values 700 losers))))))))))
;;; Trivial utility -- like map, but filter out #f's.
(define (filter-map f lis)
(let lp ((ans '()) (lis lis))
(if (pair? lis)
(lp (cond ((f (car lis)) => (lambda (val) (cons val ans)))
(else ans))
(cdr lis))
(reverse ans))))
(define (%sendmail from local-host to dest-host message)
(let ((socket (smtp/open dest-host)))
(smtp-transactions socket
(smtp/helo socket local-host)
(smtp/mail socket from)
(smtp/rcpt socket to)
(smtp/data socket message)
(smtp/quit socket))))
;;; EXPN, VRFY, MAIL-HELP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These three are simple queries of the server.
(define (smtp-query socket query arg)
(receive (code text)
(smtp-transactions socket
(smtp/helo socket (system-name))
(query socket arg))
(if (not (or (= code 421) (= code 221)))
(smtp/quit socket))
(values code text)))
(define (expn name host)
(smtp-query (smtp/open host) smtp/expn name))
(define (vrfy name host)
(smtp-query (smtp/open host) smtp/vrfy name))
(define (mail-help host . details)
(smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details))))
;;; (smtp-transactions socket ?transaction1 ...)
;;; (smtp-transactions/no-close socket ?transaction1 ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These macros make it easy to do simple sequences of SMTP commands.
;;;
;;; Evaluate a series of expressions ?transaction1, ?transaction2, ...
;;; - Each expression should perform an SMTP transaction,
;;; and return two values:
;;; + CODE (the integer reply code)
;;; + TEXT (list of strings that came with the reply).
;;;
;;; - If the transaction's reply code is 221 or 421 (meaning the socket has
;;; been closed), then the transaction sequence is aborted, and the
;;; SMTP-TRANSACTIONS form returns the CODE and TEXT values for the current
;;; transaction.
;;;
;;; - If the reply code is an error code (in the four- or five-hundred range),
;;; the transaction sequence is aborted, and the fatal transaction's CODE
;;; and TEXT values are returned. SMTP-TRANSACTIONS will additionally
;;; close the socket for you; SMTP-TRANSACTIONS/NO-CLOSE will not.
;;;
;;; - If the transaction is the last in the transaction sequence,
;;; its CODE and TEXT values are returned.
;;;
;;; - Otherwise, we throw away the current CODE and TEXT values, and
;;; proceed to the next transaction.
;;;
;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence,
;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction
;;; will always close the socket.
;;;
;;; If the socket should be kept open in the case of an abort, use
;;; SMTP-TRANSACTIONS/NO-CLOSE.
;;;
;;; We abort sequences if a transaction results in a 400-class error code.
;;; So, a sequence mailing a message to five people, with 5 RCPT's, would
;;; abort if the mailing address for one of these people was wrong, rather
;;; than proceeding to mail the other four. This may not be what you want;
;;; if so, you'll have to roll your own.
(define-syntax smtp-transactions
(syntax-rules ()
((smtp-transactions socket ?T1 ?T2 ...)
(let ((s socket))
(receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...)
(if (<= 400 code) (smtp/quit s))
(values code text))))))
(define-syntax smtp-transactions/no-close
(syntax-rules ()
((smtp-transactions/no-close socket ?T1 ?T2 ...)
;; %smtp-transactions/no-close replicates the socket argument,
;; so we have to force it to be a variable.
(let ((s socket))
(%smtp-transactions/no-close s ?T1 ?T2 ...)))))
;;; SOCKET must be a variable, hence replicable.
(define-syntax %smtp-transactions/no-close
(syntax-rules ()
((%smtp-transactions/no-close socket ?T1 ?T2 ?T3 ...)
(receive (code text) ?T1
(if (or (= code 221)
(= code 421) ; Redundant, I know.
(<= 400 code))
(values code text)
(%smtp-transactions/no-close socket ?T2 ?T3 ...))))
((%smtp-transactions/no-close socket ?T1)
?T1)))
;;; I can't make this nested definition work. I'm not enough of a macro stud.
;(define-syntax smtp-transactions/no-close
; (syntax-rules ()
; ((smtp-transactions/no-close socket ?T1 ...)
; (letrec-syntax ((%smtp-transactions/no-close
; (syntax-rules ()
;
; ((%smtp-transactions/no-close socket ?T1 ?T2 ...)
; (receive (code text) ?T1
; (if (or (= code 221)
; (= code 421) ; Redundant, I know.
; (<= 400 code))
; (values code text)
; (%smtp-transactions/no-close socket ?T2 ...))))
;
; ((%smtp-transactions/no-close socket ?T1)
; ?T1))))
;
; ;; %smtp-transactions/no-close replicates the socket argument,
; ;; so we have to force it to be a variable.
; (let ((s socket))
; (%smtp-transactions/no-close s ?T1 ...))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The basics of the protocol
(define (nullary-smtp-command command)
(lambda (socket)
(let ((port (socket:outport socket)))
(write-string command port)
(write-crlf port))
(handle-smtp-reply socket)))
(define (unary-smtp-command command)
(lambda (socket data)
(let ((port (socket:outport socket)))
(write-string command port)
(display #\space port)
(write-string data port)
(write-crlf port))
(handle-smtp-reply socket)))
(define (smtp/open host . maybe-port)
(let ((sock (socket-connect protocol-family/internet socket-type/stream host
(:optional maybe-port "smtp"))))
(receive (code text) (handle-smtp-reply sock)
(if (< code 400) sock
(error "SMTP socket-open server-reply error" sock code text)))))
;; HELLO <local-hostname>
(define smtp/helo (unary-smtp-command "HELO"))
;; MAIL FROM: <sender-address>
(define smtp/mail (unary-smtp-command "MAIL FROM:"))
;; RECIPIENT TO: <destination-address>
(define smtp/rcpt (unary-smtp-command "RCPT TO:"))
;; DATA
(define smtp/data
(let ((send-DATA-msg (nullary-smtp-command "DATA")))
(lambda (socket message) ; MESSAGE is a string or an input port.
(receive (code text) (send-DATA-msg socket)
(if (>= code 400) (values code text) ; Error.
;; We got a positive acknowledgement for the DATA msg,
;; now send the message body.
(let ((p (socket:outport socket)))
(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)
(handle-smtp-reply socket)))))))
;; SEND FROM: <sender-address>
(define smtp/send (unary-smtp-command "SEND FROM:"))
;; SEND OR MAIL <sender-address>
(define smtp/soml (unary-smtp-command "SOML FROM:"))
;; SEND AND MAIL <sender-address>
(define smtp/saml (unary-smtp-command "SOML SAML:"))
;; RESET
(define smtp/rset (nullary-smtp-command "RSET"))
;; VERIFY <user>
(define smtp/vrfy (unary-smtp-command "VRFY"))
;; EXPAND <user>
(define smtp/expn (unary-smtp-command "EXPN"))
;; HELP <details>
(define smtp/help
(let ((send-help (unary-smtp-command "HELP")))
(lambda (socket . details)
(send-help socket (apply string-append details)))))
;; NOOP
(define smtp/noop (nullary-smtp-command "NOOP"))
;; QUIT
(define smtp/quit
(let ((quit (nullary-smtp-command "QUIT")))
(lambda (socket)
(receive (code text) (quit socket) ; Quit & close socket gracefully.
(case code
((221 421))
(else (close-socket socket))) ; But close in any event.
(values code text)))))
;; TURN
(define smtp/turn (nullary-smtp-command "TURN"))
;;; Read and handle the reply. Return an integer (the reply code),
;;; and a list of the text lines that came tagged by the reply code.
;;; The text lines have the reply-code prefix (first 4 chars) and the
;;; terminating cr/lf's stripped.
;;;
;;; In bdc's analog of this proc, he would read another reply if the code was
;;; in the one-hundred range (1xx). These codes aren't even used in smtp,
;;; according to the RFC. So why?
(define (handle-smtp-reply socket)
(receive (code text) (read-smtp-reply (socket:inport socket))
(case code
((221 421) (close-socket socket))) ; All done.
(values code text)))
;;; Read a reply from the SMTP server. Returns two values:
;;; - CODE Integer. The reply code.
;;; - TEXT String list. A list of the text lines comprising the reply.
;;; Each line of text is stripped of the initial reply-code
;;; numerals (e.g., the first four chars of the reply), and
;;; the trailing cr/lf. We are in fact generous about what
;;; we take to be a line -- the protocol requires cr/lf
;;; terminators, but we'll accept just lf. This appears to
;;; true to the spirit of the "be strict in what you send,
;;; and generous in what you accept" Internet protocol philosphy.
(define (read-smtp-reply port)
(let lp ((replies '()))
(let ((ln (read-crlf-line port)))
(if (eof-object? ln)
(values 621 (cons "Premature EOF during smtp reply."
(reverse replies)))
(receive (code line more?) (parse-smtp-reply ln)
(let ((replies (cons line replies)))
(if more? (lp replies)
(values code (reverse replies)))))))))
;;; Parse a line of SMTP reply. Return three values:
;;; CODE integer - the reply code that prefixes the string.
;;; REST string - the rest of the line.
;;; MORE? boolean - is there more reply to read (i.e., was the numeric
;;; reply code terminated by a "-" character?)
(define (parse-smtp-reply line)
(if (and (string? line) ; This is all checking
(> (string-length line) 3) ; to see if the line
(char-numeric? (string-ref line 0)) ; is properly formatted.
(char-numeric? (string-ref line 1))
(char-numeric? (string-ref line 2))
(let ((c (string-ref line 3)))
(or (char=? c #\space) (char=? c #\-))))
(values (string->number (substring line 0 3)) ; It is.
(substring line 4 (string-length line))
(char=? (string-ref line 3) #\-))
(values 600 ; It isn't.
(string-append "Improperly-formatted smtp reply: " line)
#f)))
;;; The message body of a piece of email is terminated by the sequence
;;; <crlf> <period> <crlf>
;;; If the message body contains this magic sequence, it has to be escaped.
;;; We do this by mapping the sequence <lf> <period> to <lf> <period> <period>;
;;; the SMTP receiver undoes this mapping.
;;; S is a string to stuff, PCHAR was the character read just before S
;;; (which matters if it is a line-feed). If S is the first chunk of the entire
;;; msg, then PCHAR can be #f. Return two values: the stuffed string, and the
;;; last char in S (or PCHAR if S is empty). The last-char value returned can
;;; be used as the PCHAR arg for the following call to SMTP-STUFF.
(define (smtp-stuff s pchar)
(let* ((slen (string-length s))
(hits ; Count up all the <lf> <period> seqs in the string.
(let lp ((count 0)
(nl? (eqv? pchar #\newline)) ; Was last char a newline?
(i 0))
(if (< i slen)
(let ((c (string-ref s i)))
(lp (if (and nl? (char=? c #\.)) (+ count 1) count)
(eq? c #\newline)
(+ i 1)))
count))))
(values (if (zero? hits) s
;; Make a new string, and do the dot-stuffing copy.
(let ((ns (make-string (+ hits slen))))
(let lp ((nl? (eqv? pchar #\newline))
(i 0) ; S index.
(j 0)) ; NS index.
(if (< i slen)
(let ((c (string-ref s i)))
(string-set! ns j 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)))))))
ns))
(if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR
;;; Reply codes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This material taken from the RFC.
;;;
;;; 1yz Positive Preliminary reply
;;;
;;; The command has been accepted, but the requested action
;;; is being held in abeyance, pending confirmation of the
;;; information in this reply. The sender-SMTP should send
;;; another command specifying whether to continue or abort
;;; the action.
;;;
;;; [Note: SMTP does not have any commands that allow this
;;; type of reply, and so does not have the continue or
;;; abort commands.]
;;;
;;; 2yz Positive Completion reply
;;;
;;; The requested action has been successfully completed. A
;;; new request may be initiated.
;;;
;;; 3yz Positive Intermediate reply
;;;
;;; The command has been accepted, but the requested action
;;; is being held in abeyance, pending receipt of further
;;; information. The sender-SMTP should send another command
;;; specifying this information. This reply is used in
;;; command sequence groups.
;;;
;;; 4yz Transient Negative Completion reply
;;;
;;; The command was not accepted and the requested action did
;;; not occur. However, the error condition is temporary and
;;; the action may be requested again. The sender should
;;; return to the beginning of the command sequence (if any).
;;; It is difficult to assign a meaning to "transient" when
;;; two different sites (receiver- and sender- SMTPs) must
;;; agree on the interpretation. Each reply in this category
;;; might have a different time value, but the sender-SMTP is
;;; encouraged to try again. A rule of thumb to determine if
;;; a reply fits into the 4yz or the 5yz category (see below)
;;; is that replies are 4yz if they can be repeated without
;;; any change in command form or in properties of the sender
;;; or receiver. (E.g., the command is repeated identically
;;; and the receiver does not put up a new implementation.)
;;;
;;; 5yz Permanent Negative Completion reply
;;;
;;; The command was not accepted and the requested action did
;;; not occur. The sender-SMTP is discouraged from repeating
;;; the exact request (in the same sequence). Even some
;;; "permanent" error conditions can be corrected, so the
;;; human user may want to direct the sender-SMTP to
;;; reinitiate the command sequence by direct action at some
;;; point in the future (e.g., after the spelling has been
;;; changed, or the user has altered the account status).
;;;
;;;The second digit encodes responses in specific categories:
;;;
;;; x0z Syntax -- These replies refer to syntax errors,
;;; syntactically correct commands that don't fit any
;;; functional category, and unimplemented or superfluous
;;; commands.
;;;
;;; x1z Information -- These are replies to requests for
;;; information, such as status or help.
;;;
;;; x2z Connections -- These are replies referring to the
;;; transmission channel.
;;;
;;; x3z Unspecified as yet.
;;;
;;; x4z Unspecified as yet.
;;;
;;; x5z Mail system -- These replies indicate the status of
;;; the receiver mail system vis-a-vis the requested
;;; transfer or other mail system action.
;;; Complete list (grouped by function)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 500 Syntax error, command unrecognized
;;; [This may include errors such as command line too long]
;;; 501 Syntax error in parameters or arguments
;;; 502 Command not implemented
;;; 503 Bad sequence of commands
;;; 504 Command parameter not implemented
;;;
;;; 211 System status, or system help reply
;;; 214 Help message
;;; [Information on how to use the receiver or the meaning of a
;;; particular non-standard command; this reply is useful only
;;; to the human user]
;;;
;;; 220 <domain> Service ready
;;; 221 <domain> Service closing transmission channel
;;; 421 <domain> Service not available,
;;; closing transmission channel
;;; [This may be a reply to any command if the service knows it
;;; must shut down]
;;;
;;; 250 Requested mail action okay, completed
;;; 251 User not local; will forward to <forward-path>
;;; 450 Requested mail action not taken: mailbox unavailable
;;; [E.g., mailbox busy]
;;; 550 Requested action not taken: mailbox unavailable
;;; [E.g., mailbox not found, no access]
;;; 451 Requested action aborted: error in processing
;;; 551 User not local; please try <forward-path>
;;; 452 Requested action not taken: insufficient system storage
;;; 552 Requested mail action aborted: exceeded storage allocation
;;; 553 Requested action not taken: mailbox name not allowed
;;; [E.g., mailbox syntax incorrect]
;;; 354 Start mail input; end with <CRLF>.<CRLF>
;;; 554 Transaction failed
;;;
;;; State diagram
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; CONNECTION ESTABLISHMENT
;;; S: 220
;;; F: 421
;;; HELO
;;; S: 250
;;; E: 500, 501, 504, 421
;;; MAIL
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 421
;;; RCPT
;;; S: 250, 251
;;; F: 550, 551, 552, 553, 450, 451, 452
;;; E: 500, 501, 503, 421
;;; DATA
;;; I: 354 -> data -> S: 250
;;; F: 552, 554, 451, 452
;;; F: 451, 554
;;; E: 500, 501, 503, 421
;;; RSET
;;; S: 250
;;; E: 500, 501, 504, 421
;;; SEND
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 502, 421
;;; SOML
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 502, 421
;;; SAML
;;; S: 250
;;; F: 552, 451, 452
;;; E: 500, 501, 502, 421
;;; VRFY
;;; S: 250, 251
;;; F: 550, 551, 553
;;; E: 500, 501, 502, 504, 421
;;; EXPN
;;; S: 250
;;; F: 550
;;; E: 500, 501, 502, 504, 421
;;; HELP
;;; S: 211, 214
;;; E: 500, 501, 502, 504, 421
;;; NOOP
;;; S: 250
;;; E: 500, 421
;;; QUIT
;;; S: 221
;;; E: 500
;;; TURN
;;; S: 250
;;; F: 502
;;; E: 500, 503

16
scheme/lib/sunet-utilities.scm Normal file
View File

@ -0,0 +1,16 @@
; some useful utilities
(define (host-name-or-ip addr)
(with-fatal-error-handler
(lambda (condition more)
(call-with-values
(lambda () (socket-address->internet-address addr))
(lambda (ip port)
(format-internet-host-address ip))))
(host-info:name (host-info addr))))
(define (on-interrupt interrupt thunk)
(let lp ((event (most-recent-sigevent)))
(let ((next (next-sigevent event interrupt)))
(thunk)
(lp next))))

301
scheme/lib/uri.scm Normal file
View File

@ -0,0 +1,301 @@
;;; -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; URI syntax -- [scheme] : path [? search ] [# fragmentid]
;;; Imports and non-R4RS'isms
;;; let-optionals
;;; receive values (MV return)
;;; ascii->char char->ascii
;;; index rindex
;;; char-set-index char-set-rindex
;;; string-reduce
;;; char-set package
;;; bitwise logical funs and arithmetic-shift
;;; join-strings (scsh field-reader code.)
;;; References:
;;; - ftp://ftp.internic.net/rfc/rfc1630.txt
;;; Original RFC
;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/URI_Overview.html
;;; General Web page of URI pointers.
;;; I wrote a URI parser that slavishly obeyed Tim Berners-Lee's
;;; spec (rfc 1630). This was a waste of time, as most URL's do not
;;; obey his spec, which is incomplete and inconsistent with the URL spec
;;; in any event. This parser is much simpler. It parses a URI into four
;;; fields:
;;; [ <scheme> ] : <path> [ ? <search> ] [ # fragid ]
;;; The returned fields are *not* unescaped, as the rules for parsing the
;;; <path> component in particular need unescaped text, and are dependent
;;; on <scheme>. The URL parser is responsible for doing this.
;;; If the <scheme>, <search> or <fragid> portions are not specified,
;;; they are #f. Otherwise, <scheme>, <search>, and <fragid> are strings;
;;; <path> is a non-empty string list.
;;; The parsing technique is inwards from both ends.
;;; - First we search forwards for the first reserved char (= ; / # ? : space)
;;; If it's a colon, then that's the <scheme> part, otw no <scheme> part.
;;; Remove it.
;;; - Then we search backwards from the end for the last reserved char.
;;; If it's a sharp, then that's the <fragment-id> part -- remove it.
;;; - Then we search backwards from the end for the last reserved char.
;;; If it's a question-mark, then that's the <search> part -- remove it.
;;; - What's left is the path. Split at slashes. "" -> ("")
;;;
;;; This scheme is tolerant of the various ways people build broken
;;; URI's out there on the Net , p.e. \#= is a reserved character, but
;;; used unescaped in the search-part. It was given to me by Dan
;;; Connolly of the W3C and slightly modified.
;;; Returns four values: scheme, path, search, frag-id. Each value is
;;; either #f or a string except of the path, which is a nonempty list
;;; of string (as mentioned above).
(define uri-reserved (string->char-set ";/#?: ="))
(define (parse-uri s)
(let* ((slen (string-length s))
;; Search forwards for colon (or intervening reserved char).
(rs1 (string-index s uri-reserved)) ; 1st reserved char
(colon (and rs1 (char=? (string-ref s rs1) #\:) rs1))
(path-start (if colon (+ colon 1) 0))
;; Search backwards for # (or intervening reserved char).
(rs-last (string-index-right s uri-reserved))
(sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last))
;; Search backwards for ? (or intervening reserved char).
;; (NB: #\= may be after #\? and before #\#)
(rs-penult (string-index-right
s
(char-set-delete uri-reserved #\=)
(or sharp slen)))
(ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult))
(path-end (or ques sharp slen)))
(values (and colon (substring s 0 colon))
(split-uri-path s path-start path-end)
(and ques (substring s (+ ques 1) (or sharp slen)))
(and sharp (substring s (+ sharp 1) slen)))))
;;; Caution:
;;; Don't use this proc until *after* you've parsed the URL -- unescaping
;;; might introduce reserved chars (like slashes and colons) that could
;;; blow your parse.
(define (unescape-uri s . maybe-start/end)
(let-optionals maybe-start/end ((start 0)
(end (string-length s)))
(let* ((esc-seq? (lambda (i) (and (< (+ i 2) end)
(char=? (string-ref s i) #\%)
(hex-digit? (string-ref s (+ i 1)))
(hex-digit? (string-ref s (+ i 2))))))
(hits (let lp ((i start) (hits 0)) ; count # of esc seqs.
(if (< i end)
(if (esc-seq? i)
(lp (+ i 3) (+ hits 1))
(lp (+ i 1) hits))
hits))))
(if (and (zero? hits) (zero? start) (= end (string-length s))) s
(let* ((nlen (- (- end start) (* hits 2))) ; the new
; length of the
; unescaped
; string
(ns (make-string nlen))) ; stores the result
(let lp ((i start) (j 0)) ; sweap over the string
(if (< j nlen)
(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)))
(+ j 1))))
ns)))))
(define hex-digit?
(let ((hex-digits (string->char-set "0123456789abcdefABCDEF")))
(lambda (c) (char-set-contains? hex-digits c))))
; make use of the fact that numbers and characters are in order in the ascii table
(define (hexchar->int c)
(- (char->ascii c)
(if (char-numeric? c)
(char->ascii #\0)
(- (if (char-upper-case? c)
(char->ascii #\A)
(char->ascii #\a))
10))))
(define int->hexchar
(let ((table '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
#\A #\B #\C #\D #\E #\F)))
(lambda (i) (vector-ref table i))))
;;; Caution:
;;; All reserved chars (e.g., slash, sharp, colon) get escaped: "=;/#?: "
;;; So don't apply this proc to chunks of text with syntactically meaningful
;;; reserved chars (e.g., paths with URI slashes or colons) -- they'll be
;;; escaped, and lose their special meaning. E.g. it would be a mistake
;;; to apply ESCAPE-URI to "//lcs.mit.edu:8001/foo/bar.html" because the
;;; slashes and colons would be escaped.
(define uri-escaped-chars
(char-set-complement (char-set-union char-set:letter+digit
(string->char-set "$-_@.&!*\"'(),+"))))
;;; Takes a set of chars to escape. This is because we sometimes need to
;;; escape larger sets of chars for different parts of a URI.
(define (escape-uri s . maybe-escaped-chars)
(let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars))
(let ((nlen (string-fold
(lambda (c i)
(+ i
(if (char-set-contains? escaped-chars c)
3 1)))
0
s))) ; new length of escaped string
(if (= nlen (string-length s)) s
(let ((ns (make-string nlen)))
(string-fold
(lambda (c i) ; replace each occurance of an
; character to escape with %ff where ff
; is the ascii-code in hexadecimal
; notation
(+ 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))))
0
s)
ns)))))
;;; Four args: context URI's <scheme> : <path> values, and
;;; main URI's <scheme> : <path> values.
;;; If the path cannot be resolved, return #f #f (this occurs if <path>
;;; begins with n sequential slashes, and <context-path> doesn't
;;; have that many sequential slashes anywhere). All paths are
;;; represented as non-empty lists.
(define (resolve-uri cscheme cp scheme p)
(if scheme (values scheme p) ; If URI has own <scheme>, it is absolute.
(if (and (pair? p) (string=? (car p) "")) ; Path P begins with a slash.
(receive (numsl p) ; Count and strip off initial
(do ((i 1 (+ i 1)) ; slashes (i.e., initial ""'s)
(q (cdr p) (cdr q)))
((or (null? q) (not (string=? (car q) "")))
(values i q)))
;; Skip through CP until we find that many sequential /'s.
(let lp ((cp-tail cp)
(rhead '()) ; CP prefix, reversed.
(j 0)) ; J counts sequential /
(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))))
((pair? cp-tail) ; Keep looking.
(lp (cdr cp-tail)
(cons (car cp-tail) rhead)
1))
(else (values #f #f))))) ; Lose.
;; P doesn't begin with a slash.
(values cscheme (simplify-uri-path
(rev-append (cdr (reverse cp)) ; Drop non-dir part
p)))))) ; and append P.
(define (rev-append a b) ; (append (reverse a) b)
(let rev-app ((a a) (b b)) ; Should be defined in a list-proc
(if (pair? a) ; package, not here.
(rev-app (cdr a) (cons (car a) b))
b)))
;;; Cribbed from scsh's fname.scm
(define (split-uri-path uri start end) ; Split at /'s (infix grammar).
(let split ((i start)) ; "" -> ("")
(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.
;;; This procedure doesn't escape them for you; you must do that yourself:
;;; (uri-path-list->path (map escape-uri pathlist))
(define (uri-path-list->path plist)
(string-join plist "/")) ; Insert slashes between elts of PLIST.
;;; Remove . and <segment>/.. elements from path. The result is a
;;; (maybe empty) list representing a path that does not contain "."
;;; and ".." elements neither at the beginning nor somewhere else. I
;;; tried to follow RFC2396 here. The procedure returns #f if the path
;;; tries to back up past root (like "//.." or "/foo/../.."). "//" may
;;; occur somewhere in the path but not being backed up. Usually,
;;; relative paths are intended to be used with a base
;;; url. Accordingly to RFC2396 (as I hope) relative paths are
;;; considered not to start with "/". They are appended to a base
;;; URL-path and then simplified. So before you start to simplify a
;;; URL try to find out if it is a relative path (i.e. it does not
;;; start with a "/").
(define (simplify-uri-path p)
(if (null? p) #f ; P must be non-null
(let lp ((path-list (cdr p))
(stack (list (car p))))
(if (null? path-list) ; we're done
(reverse stack)
(cond
((string=? (car path-list) "..") ; back up
; neither the empty path nor root
(if (not (or (null? stack) (string=? (car stack) "")))
(lp (cdr path-list) (cdr stack))
#f))
((string=? (car path-list) ".") ; leave this
(lp (cdr path-list) stack))
((string=? (car path-list) "") ; back to root
(lp (cdr path-list) '("")))
(else ; usual segment
(lp (cdr path-list) (cons (car path-list) stack))))))))

152
scheme/lib/url.scm Normal file
View File

@ -0,0 +1,152 @@
;;; URL parsing and unparsing -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.
;;; I'm only implementing http URL's right now.
;;; References:
;;; - ftp://ftp.internic.net/rfc/rfc1738.txt
;;; Original RFC
;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/Overview.html
;;; General Web page of URI pointers.
;;; Unresolved issues:
;;; - The userhost parser shouldn't substitute default values --
;;; that should happen in a separate step.
;;; Imports and non-R4RS'isms
;;; define-record Record structures
;;; receive values MV return
;;; URI support
;;; string-index
;;; The steps in hacking a URL are:
;;; - Take the UID, parse it, and resolve it with the context UID, if any.
;;; - Consult the UID's <scheme>. Pick the appropriate URL parser and parse.
;;; Userhost strings: //<user>:<password>@<host>:<port>/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A USERHOST record describes path-prefixes of the form
;;; //<user>:<password>@<host>:<port>/
;;; These are frequently used as the initial prefix of URL's describing
;;; Internet resources.
(define-record userhost ; Each slot is a decoded string or #f.
user
password
host
port)
;;; Parse a URI path (a list representing a path, not a string!) into
;;; a userhost record. Default values are taken from the userhost
;;; record DEFAULT except for the host. Returns a userhost record if
;;; it wins. CADDR drops the userhost portion of the path. In fact,
;;; fatal-syntax-error is called, if the path doesn't start with '//'.
(define (parse-userhost path default)
(if (and (pair? path) ; The thing better begin
(string=? (car path) "") ; with // (i.e., have two
(pair? (cdr path)) ; initial "" elements).
(string=? (cadr path) ""))
(let* ((uhs (caddr path)) ; Userhost string.
(uhs-len (string-length uhs))
; Usr:passwd at-sign,
(at (string-index uhs #\@)) ; if any.
(colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon,
(colon1 (and colon1 (< colon1 at) colon1)) ; if any.
(colon2 (string-index uhs #\: (or at 0)))) ; Host:port colon,
; if any.
(make-userhost (if at
(unescape-uri uhs 0 (or colon1 at))
(userhost:user default))
(if colon1
(unescape-uri uhs (+ colon1 1) at)
(userhost:password default))
(unescape-uri uhs (if at (+ at 1) 0)
(or colon2 uhs-len))
(if colon2
(unescape-uri uhs (+ colon2 1) uhs-len)
(userhost:port default))))
(fatal-syntax-error "URL must begin with //..." path)))
;;; Unparser
(define userhost-escaped-chars
(char-set-union uri-escaped-chars ; @ and : are also special
(string->char-set "@:"))) ; in UH strings.
(define (userhost->string uh)
(let* ((us (userhost:user uh))
(pw (userhost:password uh))
(ho (userhost:host uh))
(po (userhost:port uh))
;; Encode before assembly in case pieces contain colons or at-signs.
(e (lambda (s) (escape-uri s userhost-escaped-chars)))
(user/passwd (if us `(,(e us) . ,(if pw `(":" ,(e pw) "@") '("@")))
'()))
(host/port (if ho `(,(e ho) . ,(if po `(":" ,(e po)) '()))
'())))
(apply string-append (append user/passwd host/port))))
;;; HTTP URL parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The PATH slot of this record is the URL's path split at slashes,
;;; e.g., "foo/bar//baz/" => ("foo" "bar" "" "baz" "")
;;; These elements are in raw, unescaped format. To convert back to
;;; a string, use (uri-path-list->path (map escape-uri pathlist)).
(define-record http-url
userhost ; Initial //anonymous@clark.lcs.mit.edu:80/
path ; Rest of path, split at slashes & decoded.
search
frag-id)
;;; The URI parser (parse-uri in uri.scm) maps a string to four parts:
;;; <scheme> : <path> ? <search> # <frag-id> <scheme>, <search>, and
;;; <frag-id> are strings; <path> is a non-empty string list -- the
;;; URI's path split at slashes. Optional parts of the URI, when
;;; missing, are specified as #f. If <scheme> is "http", then the
;;; other three parts can be passed to PARSE-HTTP-URL, which parses
;;; them into a HTTP-URL record. All strings come back from the URI
;;; parser encoded. SEARCH and FRAG-ID are left that way; this parser
;;; decodes the path elements.
;;;
;;; Returns a HTTP-URL record, if possible. Otherwise
;;; FATAL-SYNTAX-ERROR is called.
(define (parse-http-url path search frag-id)
(let ((uh (parse-userhost path default-http-userhost)))
(if (or (userhost:user uh) (userhost:password uh))
(fatal-syntax-error
"HTTP URL's may not specify a user or password field" path))
(make-http-url uh (map unescape-uri (cdddr path)) search frag-id)))
;;; Default http port is 80.
(define default-http-userhost (make-userhost #f #f #f "80"))
;;; Unparse.
(define (http-url->string url)
(string-append "http://"
(userhost->string (http-url:userhost url))
"/"
(uri-path-list->path (map escape-uri (http-url:path url)))
(cond ((http-url:search url) =>
(lambda (s) (string-append "?" s)))
(else ""))
(cond ((http-url:frag-id url) =>
(lambda (fi) (string-append "#" fi)))
(else ""))))