Moved to lib subdirectory.
This commit is contained in:
sperber
parent
f82499bf71
commit
7e137b2ce6
|
|
@ -1,95 +0,0 @@
|
|||
;;; 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
crlf-io.scm
53
crlf-io.scm
|
|
@ -1,53 +0,0 @@
|
|||
;;; 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)))))))
|
||||
|
||||
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
;; ecm-utilities.scm -- Utility procedures for ecm-net code
|
||||
;;
|
||||
;; $Id: ecm-utilities.scm,v 1.4 2002/03/29 16:44:04 interp 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
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
;; 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))))
|
||||
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
; 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
ftp.scm
575
ftp.scm
|
|
@ -1,575 +0,0 @@
|
|||
;;; ftp.scm -- an FTP client library for the Scheme Shell
|
||||
;;
|
||||
;; $Id: ftp.scm,v 1.5 2002/04/25 09:52:42 interp 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
htmlout.scm
195
htmlout.scm
|
|
@ -1,195 +0,0 @@
|
|||
;;; 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) "<")
|
||||
(cons (ascii->char 62) ">")
|
||||
(cons (ascii->char 38) "&")
|
||||
(cons (ascii->char 34) """)))
|
||||
|
||||
(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
ls.scm
332
ls.scm
|
|
@ -1,332 +0,0 @@
|
|||
; 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
netrc.scm
393
netrc.scm
|
|
@ -1,393 +0,0 @@
|
|||
;;; netrc.scm -- parse authentication information contained in ~/.netrc
|
||||
;;
|
||||
;; $Id: netrc.scm,v 1.7 2002/04/04 23:22:28 interp 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
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
; 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
nettime.scm
76
nettime.scm
|
|
@ -1,76 +0,0 @@
|
|||
;;; nettime.scm -- obtain the time on remote machines
|
||||
;;
|
||||
;; $Id: nettime.scm,v 1.3 2002/05/12 05:32:28 interp 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
|
||||
|
|
@ -1,67 +0,0 @@
|
|||
;;; 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))))))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
; 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
pop3.scm
351
pop3.scm
|
|
@ -1,351 +0,0 @@
|
|||
;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
|
||||
;;
|
||||
;; $Id: pop3.scm,v 1.5 2002/05/12 05:53:44 interp 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
|
||||
|
|
@ -1,58 +0,0 @@
|
|||
;;; 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
rfc822.scm
219
rfc822.scm
|
|
@ -1,219 +0,0 @@
|
|||
;;; 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
smtp.scm
606
smtp.scm
|
|
@ -1,606 +0,0 @@
|
|||
;;; 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
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
; 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
uri.scm
301
uri.scm
|
|
@ -1,301 +0,0 @@
|
|||
;;; -*- 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
url.scm
152
url.scm
|
|
@ -1,152 +0,0 @@
|
|||
;;; 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 ""))))
|
||||
Loading…
Reference in New Issue