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

* Files made fit for scsh 0.6 

* Added further features from Eric Marsden:

   * ftp.scm -- a module for transfering files using the FTP protocol

   * pop3.scm -- a module for accessing a maildrop using the POP3
     protocol

   * netrc.scm -- a module for parsing users' ~/.netrc files to
     obtain authentication information

   * nettime.scm -- a module for obtaining the time from remote
     machines, using either the Time (rfc868) or the NetTime (rfc867)
     protocols.

Unfortunetaly,
pop3.scm needs further revision because of undefined procedures and
netrc.scm needs further revision.

Nevertheless they were added because, beside the problems, they fit
scsh 0.6.
This commit is contained in:
interp 2001-09-12 18:53:50 +00:00
parent 66907428e0
commit 4063467f96
16 changed files with 1481 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Readme
View File

@ -43,3 +43,5 @@ into a realistic full-blown package, but I'll gladly accept patches
and suggestions for the other parts of the net package.
-Mike
And: See the doc directory for further informations.

2
cgi-server.scm
View File

@ -185,7 +185,7 @@
("SCRIPT_NAME" . ,script-name)
("REMOTE_HOST" . ,(host-info:name (host-info raddr)))
("REMOTE_ADDR" . ,(internet-host-address->dotted-string rhost))
("REMOTE_ADDR" . ,(format-internet-host-address rhost))
;; ("AUTH_TYPE" . xx) ; Random authentication
;; ("REMOTE_USER" . xx) ; features I don't understand.

66
ecm-utilities.scm Normal file
View File

@ -0,0 +1,66 @@
;; ecm-utilities.scm -- Utility procedures for ecm-net code
;;
;; $Id: ecm-utilities.scm,v 1.1 2001/09/12 18:53:50 interp Exp $
;;
;; Copyright (C) 1998 Eric Marsden
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License for more details.
;;
;; You should have received a copy of the GNU Library General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; 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))))
(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)))
;; prefer this to :optional
(define (safe-first x) (and (not (null? x)) (car x)))
(define (safe-second x) (and (not (null? (cdr x))) (cadr x)))
(define (write-crlf port)
(write-string "\r\n" port)
(force-output port))
(define (dump fd)
(let loop ((c (read-char fd)))
(cond ((not (eof-object? c))
(write-char c)
(loop (read-char fd))))))
(define-syntax when
(syntax-rules ()
((when bool body1 body2 ...)
(if bool (begin body1 body2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless bool body1 body2 ...)
(if (not bool) (begin body1 body2 ...)))))
;; EOF

32
format-net.scm Normal file
View File

@ -0,0 +1,32 @@
;; Does pretty-print of internet-addresses (IPv4)
;; ADDRESS address to pretty-print
;; SEPERATOR optional, defaults to ".", seperator between address-parts
;; Example:
;; (format-internet-host-address #x0a00ffff)
;; ==> "10.0.255.255"
;; (format-internet-host-address #x0a00ffff ":")
;; ==> "10:0:255:255"
(define (format-internet-host-address address . maybe-separator)
(define (extract 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))))

593
ftp.scm Normal file
View File

@ -0,0 +1,593 @@
;;; ftp.scm -- an FTP client library for the Scheme Shell
;;
;; $Id: ftp.scm,v 1.1 2001/09/12 18:53:50 interp Exp $
;;
;; Copyright (C) 1998 Eric Marsden
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License for more details.
;;
;; You should have received a copy of the GNU Library General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; 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, 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))
"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-optionals* args
((login
;; (netrc:lookup-login (ftp-connection:host-name connection))
"anonymous")
(password
;;(netrc:lookup-password
;; (ftp-connection:host-name connection))
(user-mail-address)))
(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 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")
((eq? type 'text) "A")
(else
(call-error "type must be one of 'binary or 'text" 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))
(let ((status (ftp:read-response connection "2..")))
(close-socket newsock)
(close-socket sock)
status))))
;;: 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))
(let ((status (ftp:read-response connection "2..")))
(close-socket newsock)
(close-socket sock)
status))))
;; 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)))
(let ((status (ftp:read-response connection "2..")))
(if (string? local) (close OUT))
(close-socket newsock)
(close-socket sock)
(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)
(let-optionals* opt-args ((arg #f))
(if arg
(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

4
httpd-handlers.scm
View File

@ -428,7 +428,7 @@
(with-tag #t html ()
(let ((title (string-append "Index of /"
(join-strings file-path "/"))))
(string-join (list file-path "/")))))
(with-tag #t head ()
(emit-title #t title))
(with-tag #t body ()
@ -516,7 +516,7 @@
(lambda (root path-list)
(let ((fname (if (null? path-list) root ; Bogus hack.
(string-append (file-name-as-directory root)
(join-strings path-list "/")))))
(string-join (list path-list "/"))))))
(and (not (regexp-exec dotdot-re fname)) ; Check for .. subdir.
fname)))))

2
info-gateway.scm
View File

@ -340,7 +340,7 @@
(define (char-splitter c)
(lambda (s)
(cond ((index s c)
(cond ((string-index s c)
=> (lambda (i)
(values (substring s 0 i)
(substring s (+ 1 i) (string-length s)))))

2
ls.scm
View File

@ -200,7 +200,7 @@
(if (eq? (file-info:type info) 'symlink)
(begin
(display " -> " port)
(display (read-symlink (car file) port))))
(display (read-symlink (car file)) port)))
(newline port)))
(define *year-seconds* (* 365 24 60 60))

134
modules.scm
View File

@ -1,6 +1,17 @@
;;; Scheme 48 module definitions for TCP/IP protocol suites.
;;; Copyright (c) 1995 by Olin Shivers.
(define-interface format-net-interface
(export format-internet-host-address
format-port))
(define-structure format-net format-net-interface
(open scsh
scheme
let-opt) ; :optional
(files format-net))
(define-interface smtp-interface
(export sendmail %sendmail
expn vrfy mail-help
@ -316,6 +327,7 @@
scsh-utilities ; INDEX
scsh ; syscalls
formats ; format
format-net ; FORMAT-INTERNET-HOST-ADDRESS
scheme)
(files cgi-server))
@ -364,6 +376,8 @@
htmlout
conditions ; CONDITION-STUFF
url ; HTTP-URL record type
handle-fatal-error ; WITH-FATAL-ERROR-HANDLER
string-lib ; STRING-JOIN
scheme)
(files httpd-handlers))
@ -385,6 +399,7 @@
handle ; IGNORE-ERROR
strings ; SKIP-WHITESPACE
parse-html-forms ; PARSE-HTML-FORM-QUERY
threads ; SLEEP
scheme)
(files seval))
@ -421,6 +436,7 @@
url
uri
scsh
handle-fatal-error
scheme)
(files info-gateway))
@ -446,6 +462,7 @@
handle-fatal-error
scsh
let-opt
string-lib
scheme)
(files rman-gateway))
@ -480,6 +497,123 @@
(access big-scheme)
(files ftpd))
;; some utilities for the following stuff
;; hope we can vanish this soon
(define-interface ecm-utilities-interface
(export system-fqdn
safe-first
safe-second
write-crlf
dump))
(define-structure ecm-utilities ecm-utilities-interface
(open scsh
string-lib
scheme)
(files ecm-utilities))
;; netrc.scm is a module for parsing ~/.netrc files, to obtain login
;; and password information for different network hosts.
(define-interface netrc-interface
(export user-mail-address
netrc:default-login
netrc:default-password
netrc:lookup
netrc:lookup-password
netrc:lookup-login
netrc:parse))
(define-structure netrc netrc-interface
(open defrec-package
scsh
error-package
ecm-utilities
string-lib
scheme)
(files netrc))
;; ftp.scm is a module for transfering files between networked
;; machines using the File Transfer Protocol
(define-interface ftp-interface
(export ftp:connect
ftp:login
ftp:type
ftp:rename
ftp:delete
ftp:cd
ftp:cdup
ftp:pwd
ftp:rmdir
ftp:mkdir
ftp:modification-time
ftp:size
ftp:abort
ftp:quit
ftp:ls
ftp:dir
ftp:get
ftp:put
ftp:append
ftp:quot))
(define-structure ftp ftp-interface
(open netrc
scsh
defrec-package
receiving
handle
conditions
signals
error-package
ecm-utilities
string-lib
let-opt
scheme)
(files ftp))
;; pop3.scm is a module for accessing email on a maildrop server,
;; using the POP3 protocol.
(define-interface pop3-interface
(export pop3:connect
pop3:login
pop3:stat
pop3:get
pop3:headers
pop3:last
pop3:delete
pop3:reset
pop3:quit))
(define-structure pop3 pop3-interface
(open netrc
scsh
defrec-package
handle
conditions
signals
ecm-utilities
string-lib
scheme)
(files pop3))
;; nettime.scm is a module for requesting the time on remote machines,
;; using the time or the daytime protocol
(define-interface nettime-interface
(export net:time
net:daytime))
(define-structure nettime nettime-interface
(open scsh
scheme)
(files nettime))
;;; Here is toothless.scm
;;; Shouldn't the definitions be in an extra file? Andreas.

185
netrc.scm Normal file
View File

@ -0,0 +1,185 @@
;;; netrc.scm -- parse authentication information contained in ~/.netrc
;;
;; $Id: netrc.scm,v 1.1 2001/09/12 18:53:50 interp Exp $
;;
;; Copyright (C) 1998 Eric Marsden
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License for more details.
;;
;; You should have received a copy of the GNU Library General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; 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.
;;; Entry points =======================================================
;;
;; (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.
;;
;; (netrc:default-login) -> string | #f
;; Return the default login specified by the ~/.netrc file, or #f.
;;
;; (netrc:default-password) -> string | #f
;; Return the default password specified by the ~/.netrc file, or #f.
;;
;; (netrc:lookup machine) -> string x string x string
;; Return the login,password,account information for MACHINE
;; specified by the ~/.netrc file.
;;; 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
(define (user-mail-address)
(or (getenv "REPLYTO")
(string-append (user-login-name) "@" (system-fqdn))))
(define (netrc:default-login) *netrc:default-login*)
(define (netrc:default-password) *netrc:default-password*)
;;: string -> string x string x string
(define (netrc:lookup machine)
(let ((record
(find-suchthat (lambda (rec)
(and (equal? (netrc:machine rec) machine)
(list (netrc:login rec)
(netrc:password rec)
(netrc:account rec))))
*netrc*)))
(values (netrc:login record)
(netrc:password record)
(netrc:account record))))
(define (netrc:lookup-password machine)
(receive (login password account)
(netrc:lookup machine)
password))
(define (netrc:lookup-login machine)
(receive (login password account)
(netrc:lookup machine)
login))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; nothing exported below
(define-record netrc
machine
login
password
account)
(define *netrc* '())
(define *netrc:default-login* "anonymous")
(define *netrc:default-password* (user-mail-address))
(define *netrc:file* (resolve-file-name "~/.netrc"))
(define (netrc:parse)
(netrc:check-permissions)
(set! *netrc* '())
(let ((fd (open-input-file *netrc:file*)))
(for-each-line netrc:parse-line fd)))
;; raise error if any permissions are set for group or others.
(define (netrc:check-permissions)
(let ((perms (- (file-mode *netrc:file*) 32768)))
(if (positive? (bitwise-and #b000111111 perms))
(error "Not parsing ~/.netrc file; dangerous permissions"))))
(define (netrc:try-match target line)
(let ((match (string-match target line)))
(and match
(match:substring match 1))))
(define (netrc:parse-default line)
(let ((login (netrc:try-match "login[ \t]+([^ \t]+)" line))
(password (netrc:try-match "password[ \t]+([^ \t]+)" line)))
(if login
(set! *netrc:default-login* login))
(if password
(set! *netrc:default-password* password))))
(define (netrc:parse-line line)
(cond ((string-match "default" line)
(netrc:parse-default line))
(else
(let ((machine (netrc:try-match "machine[ \t]+([^ \t]+)" line))
(login (netrc:try-match "login[ \t]+([^ \t]+)" line))
(password (netrc:try-match "password[ \t]+([^ \t]+)" line))
(account (netrc:try-match "account[ \t]+([^ \t]+)" line)))
(if (or machine login password account)
(netrc:add machine login password account))))))
(define (netrc:add machine login password account)
(set! *netrc* (cons (make-netrc machine login password account) *netrc*)))
;; for testing
(define (netrc:dump)
(format #t "~%--- Dumping ~~/.netrc contents ---")
(for-each (lambda (rec)
(format #t "~% machine ~a login ~a password ~a account ~a"
(netrc:machine rec)
(netrc:login rec)
(netrc:password rec)
(netrc:account rec)))
*netrc*)
(format #t "~%--- End of ~~/.netrc contents ---~%"))
(define (for-each-line proc fd)
(let ((line (read-line fd)))
(and (not (eof-object? line))
(proc line)
(for-each-line proc fd))))
(define (find-suchthat pred l)
(if (null? l) #f
(or (pred (car l))
(find-suchthat pred (cdr l)))))
; do we need this here?
;(netrc:parse)
;; EOF

92
nettime.scm Normal file
View File

@ -0,0 +1,92 @@
;;; nettime.scm -- obtain the time on remote machines
;;
;; $Id: nettime.scm,v 1.1 2001/09/12 18:53:50 interp Exp $
;;
;; Copyright (C) 1998 Eric Marsden
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License for more details.
;;
;; You should have received a copy of the GNU Library General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; 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

363
pop3.scm Normal file
View File

@ -0,0 +1,363 @@
;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
;;
;; $Id: pop3.scm,v 1.1 2001/09/12 18:53:50 interp Exp $
;;
;; Copyright (C) 1998 Eric Marsden
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Library General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Library General Public License for more details.
;;
;; You should have received a copy of the GNU Library General Public
;; License along with this library; if not, write to the Free
;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; 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 "pop-3" "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 (string-match "\\+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
;; what are netrc:login / netrc:password supposed to do?
;; there is no equivalent procedure in netrc.scm
(define (pop3:login connection . args)
(let ((login (or (safe-first args)
(netrc:login (pop3-connection:host-name connection))
(call-error "must provide a login" pop3:login args)))
(password (or (safe-second args)
(netrc:password (pop3-connection:host-name connection))
(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 (string-match "([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 (string-match "^\\+OK (.*)" response)))
(if match (match:substring match 1)
(let ((match2 (string-match "^-ERR (.*)" response)))
(signal '-ERR (match:substring match2 1) 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 (md5 ,str))))
(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

6
rfc822.scm
View File

@ -173,7 +173,7 @@
(let-optionals maybe-separator ((sep " "))
(map (lambda (entry)
(cons (car entry)
(map (lambda (body) (join-strings body sep))
(map (lambda (body) (string-join (list body sep)))
(cdr entry))))
alist)))
@ -206,8 +206,8 @@
(let ((entry (assq name headers)))
(and entry
(pair? entry)
(join-strings (cadr entry)
(:optional maybe-sep "\n")))))
(string-join (list (cadr entry)
(:optional maybe-sep "\n"))))))

2
rman-gateway.scm
View File

@ -103,7 +103,7 @@
((find-man-file key section "man" man-path) => nroff-n-decode)
(else
(if (not (zero?
(with-env (("MANPATH" . ,(join-strings man-path ":")))
(with-env (("MANPATH" . ,(string-join (list man-path ":"))))
(run (,@rman/man ,@(if section `(,section) '()) ,key)
(< /dev/null)
(> 2 /dev/null)))))

2
uri.scm
View File

@ -262,7 +262,7 @@
;;; (uri-path-list->path (map escape-uri pathlist))
(define (uri-path-list->path plist)
(join-strings plist "/")) ; Insert slashes between elts of PLIST.
(string-join (list plist "/"))) ; Insert slashes between elts of PLIST.
;;; Remove . and <segment>/.. elements from path. The result is a

8
url.scm
View File

@ -18,7 +18,7 @@
;;; define-record Record structures
;;; receive values MV return
;;; URI support
;;; index
;;; string-index
;;; The steps in hacking a URL are:
;;; - Take the UID, parse it, and resolve it with the context UID, if any.
@ -54,12 +54,12 @@
(let* ((uhs (caddr path)) ; Userhost string.
(uhs-len (string-length uhs))
; Usr:passwd at-sign,
(at (index uhs #\@)) ; if any.
(at (string-index uhs #\@)) ; if any.
(colon1 (and at (index uhs #\:))) ; Usr:passwd colon,
(colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon,
(colon1 (and colon1 (< colon1 at) colon1)) ; if any.
(colon2 (index uhs #\: (or at 0)))) ; Host:port colon,
(colon2 (string-index uhs #\: (or at 0)))) ; Host:port colon,
; if any.
(make-userhost (if at
(unescape-uri uhs 0 (or colon1 at))