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

* changed names in ftp client from ftp:... to ftp-... 

* added ftp-obsolete package, maps the obsolete names to the new
* added ftp-error? as an exported procedure
This commit is contained in:
interp 2002-04-25 09:52:42 +00:00
parent 2fccbe9b3e
commit c5eeb471f8
3 changed files with 171 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
doc/latex/ftp.tex
View File

@ -1,7 +1,7 @@
\section{FTP client}\label{sec:ftp} \section{FTP client}\label{sec:ftp}
\begin{description} \begin{description}
\item[Used files:] ftp.scm \item[Used files:] ftp.scm, ftp-obsolete.scm
\item[Name of the package:] ftp \item[Name of the package:] ftp, ftp-obsolete
\end{description} \end{description}
\subsection{What users want to know} \subsection{What users want to know}
@ -19,16 +19,16 @@ procedures return a ``status'', which is either the server's reply as
a string, or \sharpf{} to signify failure. a string, or \sharpf{} to signify failure.
The server's response is always checked. If the server's response The server's response is always checked. If the server's response
doesn't match the expected code from the server, an catchable doesn't match the expected code from the server, a catchable
\ex{ftp:error} is raised. \ex{ftp-error} is raised.
\FIXME{The source says you can look at pop3.scm to find out how to \FIXME{The source says you can look at pop3.scm to find out how to
catch the ftp:error raised by some procedures this. We have not had catch the ftp-error raised by some procedures this. We have not had
a look there, yet.} a look there, yet.}
\subsubsection*{Entry points } \subsubsection*{Entry points }
\defun{ftp:connect} {host \ovar{logfile}} {connection} \defun{ftp-connect} {host \ovar{logfile}} {connection}
\begin{desc} \begin{desc}
Open a command connection with the remote machine \semvar{host}. Open a command connection with the remote machine \semvar{host}.
Optionally start logging the conversation with the server to Optionally start logging the conversation with the server to
@ -38,7 +38,7 @@ a look there, yet.}
\ex{og-rxw})! \ex{og-rxw})!
\end{desc} \end{desc}
\defun{ftp:login} {connection \ovar{login \ovar{passwd}}} {status} \defun{ftp-login} {connection \ovar{login \ovar{passwd}}} {status}
\begin{desc} \begin{desc}
Log in to the remote host. If a \semvar{login} and \semvar{password} Log in to the remote host. If a \semvar{login} and \semvar{password}
are not provided, they are first searched for in the user's are not provided, they are first searched for in the user's
@ -46,7 +46,7 @@ a look there, yet.}
``user@host'' ``user@host''
\end{desc} \end{desc}
\defun{ftp:type} {connection type} {status} \defun{ftp-type} {connection type} {status}
\begin{desc} \begin{desc}
Change the transfer mode for future data connections. This may be Change the transfer mode for future data connections. This may be
either \ex{'ascii }or \ex{'text}, respectively, for transfering text either \ex{'ascii }or \ex{'text}, respectively, for transfering text
@ -54,7 +54,7 @@ a look there, yet.}
\semvar{type} is a string it is sent verbatim to the server. \semvar{type} is a string it is sent verbatim to the server.
\end{desc} \end{desc}
\defun{ftp:rename} {connection oldname newname} {status} \defun{ftp-rename} {connection oldname newname} {status}
\begin{desc} \begin{desc}
Change the name of \semvar{oldname} on the remote host to Change the name of \semvar{oldname} on the remote host to
\semvar{newname} (assuming sufficient permissions). \semvar{oldname} \semvar{newname} (assuming sufficient permissions). \semvar{oldname}
@ -65,34 +65,34 @@ a look there, yet.}
the root of the servers's filesystem. the root of the servers's filesystem.
\end{desc} \end{desc}
\defun{ftp:delete} {connection file} {status} \defun{ftp-delete} {connection file} {status}
\begin{desc} \begin{desc}
Delete \semvar{file} from the remote host (assuming the user has Delete \semvar{file} from the remote host (assuming the user has
appropriate permissions). appropriate permissions).
\end{desc} \end{desc}
\defun{ftp:cd} {connection dir} {status} \defun{ftp-cd} {connection dir} {status}
\begin{desc} \begin{desc}
Change the current directory on the server. Change the current directory on the server.
\end{desc} \end{desc}
\defun{ftp:cdup} {connection} {status} \defun{ftp-cdup} {connection} {status}
\begin{desc} \begin{desc}
Move to the parent directory on the server. Move to the parent directory on the server.
\end{desc} \end{desc}
\defun{ftp:pwd} {connection} {string} \defun{ftp-pwd} {connection} {string}
\begin{desc} \begin{desc}
Return the current directory on the remote host, as a string. Return the current directory on the remote host, as a string.
\end{desc} \end{desc}
\defun{ftp:ls} {connection} {status} \defun{ftp-ls} {connection} {status}
\begin{desc} \begin{desc}
Provide a listing of the current directory's contents, in short Provide a listing of the current directory's contents, in short
format, \ie as a list of filenames. format, \ie as a list of filenames.
\end{desc} \end{desc}
\defun{ftp:dir} {connection} {status} \defun{ftp-dir} {connection} {status}
\begin{desc} \begin{desc}
Provide a listing of the current directory's contents, in long Provide a listing of the current directory's contents, in long
format. Most servers (\Unix, MS Windows, MacOS) use a standard format. Most servers (\Unix, MS Windows, MacOS) use a standard
@ -100,7 +100,7 @@ a look there, yet.}
information, but other servers (VMS, \ldots) use their own format. information, but other servers (VMS, \ldots) use their own format.
\end{desc} \end{desc}
\defun{ftp:get} {connection remote-file \ovar{local-file}} {status $|$ string} \defun{ftp-get} {connection remote-file \ovar{local-file}} {status $|$ string}
\begin{desc} \begin{desc}
Download \semvar{remote-file} from the FTP server. If Download \semvar{remote-file} from the FTP server. If
\semvar{local-file} is a string, save the data to \semvar{local-file} is a string, save the data to
@ -112,7 +112,7 @@ a look there, yet.}
\sharpf{} return the data as a string. \sharpf{} return the data as a string.
\end{desc} \end{desc}
\defun{ftp:put} {connection local-file \ovar{remote-file}} {status} \defun{ftp-put} {connection local-file \ovar{remote-file}} {status}
\begin{desc} \begin{desc}
Upload \semvar{local-file} to the FTP server. If Upload \semvar{local-file} to the FTP server. If
\semvar{remote-file} is specified, then save the data to \semvar{remote-file} is specified, then save the data to
@ -122,25 +122,25 @@ a look there, yet.}
`/'), or relative to the current directory. `/'), or relative to the current directory.
\end{desc} \end{desc}
\defun{ftp:append}{connection local-file \ovar{remote-file}}{status} \defun{ftp-append}{connection local-file \ovar{remote-file}}{status}
\begin{desc} \begin{desc}
Does the same as \ex{ftp:get}, but appends the data to the remote Does the same as \ex{ftp-get}, but appends the data to the remote
file, if it exists. file, if it exists.
\end{desc} \end{desc}
\defun{ftp:rmdir} {connection dir} {status} \defun{ftp-rmdir} {connection dir} {status}
\begin{desc} \begin{desc}
Remove the directory \semvar{dir} from the remote host (assuming Remove the directory \semvar{dir} from the remote host (assuming
sufficient permissions). sufficient permissions).
\end{desc} \end{desc}
\defun{ftp:mkdir} {connection dir} {status} \defun{ftp-mkdir} {connection dir} {status}
\begin{desc} \begin{desc}
Create a new directory named \semvar{dir} on the remote host Create a new directory named \semvar{dir} on the remote host
(assuming sufficient permissions). (assuming sufficient permissions).
\end{desc} \end{desc}
\defun{ftp:modification-time} {connection file} {date} \defun{ftp-modification-time} {connection file} {date}
\begin{desc} \begin{desc}
Request the time of the last modification of \semvar{file} on the Request the time of the last modification of \semvar{file} on the
remote host, and on success return a Scsh date record. This command remote host, and on success return a Scsh date record. This command
@ -148,30 +148,35 @@ a look there, yet.}
useful for mirroring. useful for mirroring.
\end{desc} \end{desc}
\defun{ftp:size} {connection file} {integer} \defun{ftp-size} {connection file} {integer}
\begin{desc} \begin{desc}
Return the size of \semvar{file} in bytes. Return the size of \semvar{file} in bytes.
\end{desc} \end{desc}
\defun{ftp:abort} {connection} {status} \defun{ftp-abort} {connection} {status}
\begin{desc} \begin{desc}
Abort the current data transfer. Not particularly useful with this Abort the current data transfer. Not particularly useful with this
im\-ple\-men\-ta\-tion since the data transfer commands only return im\-ple\-men\-ta\-tion since the data transfer commands only return
once the transfer is complete. once the transfer is complete.
\end{desc} \end{desc}
\defun{ftp:quit} {connection} {status} \defun{ftp-quit} {connection} {status}
\begin{desc} \begin{desc}
Close the connection to the remote host. The \semvar{connection} Close the connection to the remote host. The \semvar{connection}
object is useless after a quit command. object is useless after a quit command.
\end{desc} \end{desc}
\defun{ftp:quot}{connection command}{status} \defun{ftp-quot}{connection command}{status}
\begin{desc} \begin{desc}
Send a \semvar{command} verbatim to the remote server and wait for a Send a \semvar{command} verbatim to the remote server and wait for a
response. response.
\end{desc} \end{desc}
\defun{ftp-error?}{thing}{boolean}
\begin{desc}
Returns \sharpt, if \semvar{thing} is a \ex{ftp-error} object,
otherwise \sharpf.
\end{desc}
\subsubsection*{Unimplemented} \subsubsection*{Unimplemented}
@ -215,6 +220,14 @@ be very tricky; it only requires using passive mode. Might want to add
something like the \ex{/usr/bin/ftp} command \ex{restrict}, which something like the \ex{/usr/bin/ftp} command \ex{restrict}, which
implements data port range restrictions. implements data port range restrictions.
\subsubsection*{Obsolete procedures}
Names in further versions of \ex{ftp} contained a colon (`\ex{:}')
after the prefix `\ex{ftp-}'. This is now changed to a hyphen
('\ex{-}'), accordingly to SUnet's philosophy. If you need the old
names, use the \ex{ftp\=obsolete}-package that maps the names to the
new ones.
\subsubsection*{Portablitity} \subsubsection*{Portablitity}
@ -253,7 +266,7 @@ Items of the following list are necessary in order to use this module:
\item Improved error handling. \item Improved error handling.
\item A lot of the calls to format could be replaced by calls to \item A lot of the calls to format could be replaced by calls to
string-join. Maybe format is easier to read? string-join. Maybe format is easier to read?
\item The \ex{ftp:rename} command should have an optional argument \item The \ex{ftp-rename} command should have an optional argument
\ex{:rename} which defaults to \sharpf, which would make us upload \ex{:rename} which defaults to \sharpf, which would make us upload
to a temporary name and rename at the end of the upload. This 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 atomicity is important for ftp or http servers which are serving a

182
ftp.scm
View File

@ -1,6 +1,6 @@
;;; ftp.scm -- an FTP client library for the Scheme Shell ;;; ftp.scm -- an FTP client library for the Scheme Shell
;; ;;
;; $Id: ftp.scm,v 1.4 2002/03/19 18:42:23 interp Exp $ ;; $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> ;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
@ -17,25 +17,25 @@
;;; Entry points ======================================================= ;;; Entry points =======================================================
;; ;;
;; (ftp:connect host [logfile]) -> connection ;; (ftp-connect host [logfile]) -> connection
;; Open a command connection with the remote machine HOST. ;; Open a command connection with the remote machine HOST.
;; Optionally start logging the conversation with the server to ;; Optionally start logging the conversation with the server to
;; LOGFILE, which will be appended to if it already exists, and ;; LOGFILE, which will be appended to if it already exists, and
;; created otherwise. Beware, the LOGFILE contains passwords in ;; created otherwise. Beware, the LOGFILE contains passwords in
;; clear text (it is created with permissions og-rxw) ! ;; clear text (it is created with permissions og-rxw) !
;; ;;
;; (ftp:login connection [login passwd]) -> status ;; (ftp-login connection [login passwd]) -> status
;; Log in to the remote host. If a login and password are not ;; Log in to the remote host. If a login and password are not
;; provided, they are first searched for in the user's ~/.netrc ;; provided, they are first searched for in the user's ~/.netrc
;; file, or default to user "anonymous" and password "user@host" ;; file, or default to user "anonymous" and password "user@host"
;; ;;
;; (ftp:type connection type) -> status ;; (ftp-type connection type) -> status
;; Change the transfer mode for future data connections. This may ;; Change the transfer mode for future data connections. This may
;; be either 'ascii or 'text, respectively, for transfering text files, ;; be either 'ascii or 'text, respectively, for transfering text files,
;; or 'binary for transfering binary files. If type is a string it ;; or 'binary for transfering binary files. If type is a string it
;; is sent verbatim to the server. ;; is sent verbatim to the server.
;; ;;
;; (ftp:rename connection oldname newname) -> status ;; (ftp-rename connection oldname newname) -> status
;; Change the name of oldname on the remote host to newname ;; Change the name of oldname on the remote host to newname
;; (assuming sufficient permissions). oldname and newname are ;; (assuming sufficient permissions). oldname and newname are
;; strings; if prefixed with "/" they are taken relative to the ;; strings; if prefixed with "/" they are taken relative to the
@ -44,30 +44,30 @@
;; "anonymous" or "ftp"), the server root is different from the ;; "anonymous" or "ftp"), the server root is different from the
;; root of the servers's filesystem. ;; root of the servers's filesystem.
;; ;;
;; (ftp:delete connection file) -> status ;; (ftp-delete connection file) -> status
;; Delete file from the remote host (assuming the user has ;; Delete file from the remote host (assuming the user has
;; appropriate permissions). ;; appropriate permissions).
;; ;;
;; (ftp:cd connection dir) -> status ;; (ftp-cd connection dir) -> status
;; Change the current directory on the server. ;; Change the current directory on the server.
;; ;;
;; (ftp:cdup connection) -> status ;; (ftp-cdup connection) -> status
;; Move to the parent directory on the server. ;; Move to the parent directory on the server.
;; ;;
;; (ftp:pwd connection) -> string ;; (ftp-pwd connection) -> string
;; Return the current directory on the remote host, as a string. ;; Return the current directory on the remote host, as a string.
;; ;;
;; (ftp:ls connection) -> status ;; (ftp-ls connection) -> status
;; Provide a listing of the current directory's contents, in short ;; Provide a listing of the current directory's contents, in short
;; format, ie as a list of filenames. ;; format, ie as a list of filenames.
;; ;;
;; (ftp:dir connection) -> status ;; (ftp-dir connection) -> status
;; Provide a listing of the current directory's contents, in long ;; Provide a listing of the current directory's contents, in long
;; format. Most servers (Unix, MS Windows, MacOS) use a standard ;; format. Most servers (Unix, MS Windows, MacOS) use a standard
;; format with one file per line, with the file size and other ;; format with one file per line, with the file size and other
;; information, but other servers (VMS, ...) use their own format. ;; information, but other servers (VMS, ...) use their own format.
;; ;;
;; (ftp:get connection remote-file [local-file]) -> status | string ;; (ftp-get connection remote-file [local-file]) -> status | string
;; Download remote-file from the FTP server. If local-file is a ;; Download remote-file from the FTP server. If local-file is a
;; string, save the data to local-file on the local host; ;; string, save the data to local-file on the local host;
;; otherwise save to a local file named remote-file. remote-file ;; otherwise save to a local file named remote-file. remote-file
@ -76,36 +76,36 @@
;; output data to (current-output-file), and if it is #f return ;; output data to (current-output-file), and if it is #f return
;; the data as a string. ;; the data as a string.
;; ;;
;; (ftp:put connection local-file [remote-file]) -> status ;; (ftp-put connection local-file [remote-file]) -> status
;; Upload local-file to the FTP server. If remote-file is ;; Upload local-file to the FTP server. If remote-file is
;; specified, the save the data to remote-file on the remote host; ;; specified, the save the data to remote-file on the remote host;
;; otherwise save to a remote file named local-file. local-file ;; otherwise save to a remote file named local-file. local-file
;; and remote-file may be absolute file names (with a leading ;; and remote-file may be absolute file names (with a leading
;; `/'), or relative to the current directory. ;; `/'), or relative to the current directory.
;; ;;
;; (ftp:rmdir connection dir) -> status ;; (ftp-rmdir connection dir) -> status
;; Remove the directory DIR from the remote host (assuming ;; Remove the directory DIR from the remote host (assuming
;; sufficient permissions). ;; sufficient permissions).
;; ;;
;; (ftp:mkdir connection dir) -> status ;; (ftp-mkdir connection dir) -> status
;; Create a new directory named DIR on the remote host (assuming ;; Create a new directory named DIR on the remote host (assuming
;; sufficient permissions). ;; sufficient permissions).
;; ;;
;; (ftp:modification-time connection file) -> date ;; (ftp-modification-time connection file) -> date
;; Request the time of the last modification of FILE on the remote ;; Request the time of the last modification of FILE on the remote
;; host, and on success return a Scsh date record. This command is ;; host, and on success return a Scsh date record. This command is
;; not part of RFC959 and is not implemented by all servers, but ;; not part of RFC959 and is not implemented by all servers, but
;; is useful for mirroring. ;; is useful for mirroring.
;; ;;
;; (ftp:size connection file) -> integer ;; (ftp-size connection file) -> integer
;; Return the size of FILE in bytes. ;; Return the size of FILE in bytes.
;; ;;
;; (ftp:abort connection) -> status ;; (ftp-abort connection) -> status
;; Abort the current data transfer. Not particularly useful with ;; Abort the current data transfer. Not particularly useful with
;; this implementation since the data transfer commands only ;; this implementation since the data transfer commands only
;; return once the transfer is complete. ;; return once the transfer is complete.
;; ;;
;; (ftp:quit connection) -> status ;; (ftp-quit connection) -> status
;; Close the connection to the remote host. The connection object ;; Close the connection to the remote host. The connection object
;; is useless after a quit command. ;; is useless after a quit command.
@ -199,7 +199,7 @@
;; beware, the log file contains password information! ;; beware, the log file contains password information!
;;: string [ x string x port] -> connection ;;: string [ x string x port] -> connection
(define (ftp:connect host . args) (define (ftp-connect host . args)
(let-optionals* args ((logfile #f)) (let-optionals* args ((logfile #f))
(let* ((LOG (and logfile (let* ((LOG (and logfile
(open-output-file logfile (open-output-file logfile
@ -217,12 +217,12 @@
(connection (make-ftp-connection hostname (connection (make-ftp-connection hostname
sock sock
LOG "" ""))) LOG "" "")))
(ftp:log connection (ftp-log connection
(format #f "~%-- ~a: opened ftp connection to ~a" (format #f "~%-- ~a: opened ftp connection to ~a"
(date->string (date)) ; doesn't seem to be buggy in v0.6 (date->string (date)) ; doesn't seem to be buggy in v0.6
;"Dummy date" ; (format-time-zone) is buggy in v0.5.1 ;"Dummy date" ; (format-time-zone) is buggy in v0.5.1
hostname)) hostname))
(ftp:read-response connection "220") ; the initial welcome banner (ftp-read-response connection "220") ; the initial welcome banner
connection))) connection)))
;; Send user information to the remote host. Args are optional login ;; Send user information to the remote host. Args are optional login
@ -230,7 +230,7 @@
;; try to determine a login and password for the server. If not found we ;; try to determine a login and password for the server. If not found we
;; default to login "anonymous" with password user@host. ;; default to login "anonymous" with password user@host.
;;: connection [ x string x password ] -> status ;;: connection [ x string x password ] -> status
(define (ftp:login connection . args) (define (ftp-login connection . args)
(let ((netrc-record (netrc:parse))) (let ((netrc-record (netrc:parse)))
(let-optionals* args (let-optionals* args
((login ((login
@ -241,60 +241,60 @@
(ftp-connection:host-name connection)))) (ftp-connection:host-name connection))))
(set-ftp-connection:login connection login) (set-ftp-connection:login connection login)
(set-ftp-connection:password connection password) (set-ftp-connection:password connection password)
(ftp:send-command connection (format #f "USER ~a" login) "...") ; "331" (ftp-send-command connection (format #f "USER ~a" login) "...") ; "331"
(ftp:send-command connection (format #f "PASS ~a" password) "2..")))) ; "230" (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 ;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
;; sent verbatim ;; sent verbatim
;;: connection x symbol|string -> status ;;: connection x symbol|string -> status
(define (ftp:type connection type) (define (ftp-type connection type)
(let ((ttype (cond (let ((ttype (cond
((string? type) type) ((string? type) type)
((eq? type 'binary) "I") ((eq? type 'binary) "I")
((or (eq? type 'ascii) ((or (eq? type 'ascii)
(eq? type 'text)) "A") (eq? type 'text)) "A")
(else (else
(call-error "type must be one of 'binary or 'text or 'ascii" ftp:type type))))) (call-error "type must be one of 'binary or 'text or 'ascii" ftp-type type)))))
(ftp:send-command connection (format #f "TYPE ~a" ttype)))) (ftp-send-command connection (format #f "TYPE ~a" ttype))))
;;: connection x string x string -> status ;;: connection x string x string -> status
(define (ftp:rename connection oldname newname) (define (ftp-rename connection oldname newname)
(ftp:send-command connection (format #f "RNFR ~a" oldname) "35.") (ftp-send-command connection (format #f "RNFR ~a" oldname) "35.")
(ftp:send-command connection (format #f "RNTO ~a" newname) "25.")) (ftp-send-command connection (format #f "RNTO ~a" newname) "25."))
;;: connection x string -> status ;;: connection x string -> status
(define (ftp:delete connection file) (define (ftp-delete connection file)
(ftp:send-command connection (format #f "DELE ~a" file) "25.")) (ftp-send-command connection (format #f "DELE ~a" file) "25."))
;;: connection x string -> status ;;: connection x string -> status
(define (ftp:cd connection dir) (define (ftp-cd connection dir)
(ftp:send-command connection (format #f "CWD ~a" dir))) (ftp-send-command connection (format #f "CWD ~a" dir)))
;;: connection -> status ;;: connection -> status
(define (ftp:cdup connection) (define (ftp-cdup connection)
(ftp:send-command connection "CDUP" "250")) (ftp-send-command connection "CDUP" "250"))
;;: on success return the new directory as a string ;;: on success return the new directory as a string
(define (ftp:pwd connection) (define (ftp-pwd connection)
(let* ((response (ftp:send-command connection "PWD" "2..")) ;; 257 (let* ((response (ftp-send-command connection "PWD" "2..")) ;; 257
(match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response "")))) (match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response ""))))
(match:substring match 1))) (match:substring match 1)))
;;: connection x string -> status ;;: connection x string -> status
(define (ftp:rmdir connection dir) (define (ftp-rmdir connection dir)
(ftp:send-command connection (format #f "RMD ~a" dir))) (ftp-send-command connection (format #f "RMD ~a" dir)))
;;: connection x string -> status ;;: connection x string -> status
(define (ftp:mkdir connection dir) (define (ftp-mkdir connection dir)
(ftp:send-command connection (format #f "MKD ~a" dir))) (ftp-send-command connection (format #f "MKD ~a" dir)))
;; On success return a Scsh date record. This message is not part of ;; 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 ;; rfc959 but seems to be supported by many ftp servers (it's useful
;; for mirroring) ;; for mirroring)
;;: connection x string -> date ;;: connection x string -> date
(define (ftp:modification-time connection file) (define (ftp-modification-time connection file)
(let* ((response (ftp:send-command connection (let* ((response (ftp-send-command connection
(format #f "MDTM ~a" file))) (format #f "MDTM ~a" file)))
(match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response ""))) (match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response "")))
(timestr (and match (match:substring match 1)))) (timestr (and match (match:substring match 1))))
@ -314,8 +314,8 @@
;; On success return the size of the file in bytes. ;; On success return the size of the file in bytes.
;;: connection x string -> integer ;;: connection x string -> integer
(define (ftp:size connection file) (define (ftp-size connection file)
(let* ((response (ftp:send-command connection (let* ((response (ftp-send-command connection
(format #f "SIZE ~a" file) (format #f "SIZE ~a" file)
"2.."))) "2..")))
(and (string? response) (and (string? response)
@ -325,12 +325,12 @@
;; Abort the current data transfer. Maybe we should close the data ;; Abort the current data transfer. Maybe we should close the data
;; socket? ;; socket?
;;: connection -> status ;;: connection -> status
(define (ftp:abort connection) (define (ftp-abort connection)
(ftp:send-command connection "ABOR")) (ftp-send-command connection "ABOR"))
;;: connection -> status ;;: connection -> status
(define (ftp:quit connection) (define (ftp-quit connection)
(ftp:send-command connection "QUIT" "221") (ftp-send-command connection "QUIT" "221")
(close-socket (ftp-connection:command-socket connection))) (close-socket (ftp-connection:command-socket connection)))
@ -351,30 +351,30 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;: connection [ x string ] -> status ;;: connection [ x string ] -> status
(define (ftp:ls connection . maybe-dir) (define (ftp-ls connection . maybe-dir)
(let* ((sock (ftp:open-data-connection connection))) (let* ((sock (ftp-open-data-connection connection)))
(ftp:send-command connection (ftp-send-command connection
(ftp:build-command-string "NLST" maybe-dir) (ftp-build-command-string "NLST" maybe-dir)
"1..") "1..")
(receive (newsock newsockaddr) (receive (newsock newsockaddr)
(accept-connection sock) (accept-connection sock)
(dump (socket:inport newsock)) (dump (socket:inport newsock))
(close-socket newsock) (close-socket newsock)
(close-socket sock) (close-socket sock)
(ftp:read-response connection "2..")))) (ftp-read-response connection "2.."))))
;;: connection [ x string ] -> status ;;: connection [ x string ] -> status
(define (ftp:dir connection . maybe-dir) (define (ftp-dir connection . maybe-dir)
(let* ((sock (ftp:open-data-connection connection))) (let* ((sock (ftp-open-data-connection connection)))
(ftp:send-command connection (ftp-send-command connection
(ftp:build-command-string "LIST" maybe-dir) (ftp-build-command-string "LIST" maybe-dir)
"1..") "1..")
(receive (newsock newsockaddr) (receive (newsock newsockaddr)
(accept-connection sock) (accept-connection sock)
(dump (socket:inport newsock)) (dump (socket:inport newsock))
(close-socket newsock) (close-socket newsock)
(close-socket sock) (close-socket sock)
(ftp:read-response connection "2..")))) (ftp-read-response connection "2.."))))
;; maybe-local may be a filename to which the data should be written, ;; maybe-local may be a filename to which the data should be written,
@ -383,8 +383,8 @@
;; or nothing to output to a local file with the same name as the ;; or nothing to output to a local file with the same name as the
;; remote file. ;; remote file.
;;: connection x string [x string | #t | #f] -> status | string ;;: connection x string [x string | #t | #f] -> status | string
(define (ftp:get connection remote-file . maybe-local) (define (ftp-get connection remote-file . maybe-local)
(let* ((sock (ftp:open-data-connection connection)) (let* ((sock (ftp-open-data-connection connection))
(local (if (pair? maybe-local) (local (if (pair? maybe-local)
(car maybe-local) (car maybe-local)
'empty)) 'empty))
@ -393,7 +393,7 @@
((eq? local #f) (make-string-output-port)) ((eq? local #f) (make-string-output-port))
(else (else
(open-output-file remote-file))))) (open-output-file remote-file)))))
(ftp:send-command connection (ftp-send-command connection
(format #f "RETR ~a" remote-file) (format #f "RETR ~a" remote-file)
"150") "150")
(receive (newsock newsockaddr) (receive (newsock newsockaddr)
@ -402,7 +402,7 @@
(dump (socket:inport newsock))) (dump (socket:inport newsock)))
(close-socket newsock) (close-socket newsock)
(close-socket sock) (close-socket sock)
(let ((status (ftp:read-response connection "2.."))) (let ((status (ftp-read-response connection "2..")))
(if (string? local) (close OUT)) (if (string? local) (close OUT))
(if (eq? local #f) (if (eq? local #f)
(string-output-port-output OUT) (string-output-port-output OUT)
@ -419,36 +419,36 @@
;; the file to appear on the remote machine. If omitted the file takes ;; 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. ;; the same name on the FTP server as on the local host.
;;: connection x string [ x string ] -> status ;;: connection x string [ x string ] -> status
(define (ftp:put connection local-file . maybe-remote-file) (define (ftp-put connection local-file . maybe-remote-file)
(let-optionals* maybe-remote-file ((remote-file #f)) (let-optionals* maybe-remote-file ((remote-file #f))
(let* ((sock (ftp:open-data-connection connection)) (let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file)) (IN (open-input-file local-file))
(cmd (format #f "STOR ~a" (or remote-file local-file)))) (cmd (format #f "STOR ~a" (or remote-file local-file))))
(ftp:send-command connection cmd "150") (ftp-send-command connection cmd "150")
(receive (newsock newsockaddr) (receive (newsock newsockaddr)
(accept-connection sock) (accept-connection sock)
(with-current-output-port (socket:outport newsock) (dump IN)) (with-current-output-port (socket:outport newsock) (dump IN))
(close (socket:outport newsock)) ; send the server EOF (close (socket:outport newsock)) ; send the server EOF
(close-socket newsock) (close-socket newsock)
(let ((status (ftp:read-response connection "2.."))) (let ((status (ftp-read-response connection "2..")))
(close IN) (close IN)
(close-socket sock) (close-socket sock)
status))))) status)))))
;;: connection x string [x string] -> status ;;: connection x string [x string] -> status
(define (ftp:append connection local-file . maybe-remote-file) (define (ftp-append connection local-file . maybe-remote-file)
(let-optionals* maybe-remote-file ((remote-file #f)) (let-optionals* maybe-remote-file ((remote-file #f))
(let* ((sock (ftp:open-data-connection connection)) (let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file)) (IN (open-input-file local-file))
(cmd (format #f "APPE ~a" (or remote-file local-file)))) (cmd (format #f "APPE ~a" (or remote-file local-file))))
(ftp:send-command connection cmd "150") (ftp-send-command connection cmd "150")
(receive (newsock newsockaddr) (receive (newsock newsockaddr)
(accept-connection sock) (accept-connection sock)
(with-current-output-port (socket:outport newsock) (with-current-output-port (socket:outport newsock)
(dump IN)) (dump IN))
(close (socket:outport newsock)) ; send the server EOF (close (socket:outport newsock)) ; send the server EOF
(close-socket newsock) (close-socket newsock)
(let ((status (ftp:read-response connection "2.."))) (let ((status (ftp-read-response connection "2..")))
(close IN) (close IN)
(close-socket sock) (close-socket sock)
status))))) status)))))
@ -456,14 +456,14 @@
;; send a command verbatim to the remote server and wait for a ;; send a command verbatim to the remote server and wait for a
;; response. ;; response.
;;: connection x string -> status ;;: connection x string -> status
(define (ftp:quot connection cmd) (define (ftp-quot connection cmd)
(ftp:send-command connection cmd)) (ftp-send-command connection cmd))
;; ------------------------------------------------------------------------ ;; ------------------------------------------------------------------------
;; no exported procedures below ;; no exported procedures below
(define (ftp:open-data-connection connection) (define (ftp-open-data-connection connection)
(let* ((sock (create-socket protocol-family/internet (let* ((sock (create-socket protocol-family/internet
socket-type/stream)) socket-type/stream))
(sockaddr (internet-address->socket-address (sockaddr (internet-address->socket-address
@ -473,8 +473,8 @@
(set-socket-option sock level/socket socket/linger 120) (set-socket-option sock level/socket socket/linger 120)
(bind-socket sock sockaddr) (bind-socket sock sockaddr)
(listen-socket sock 0) (listen-socket sock 0)
(ftp:send-command connection ; send PORT command (ftp-send-command connection ; send PORT command
(ftp:build-PORT-string (socket-local-address sock))) (ftp-build-PORT-string (socket-local-address sock)))
sock)) sock))
@ -496,11 +496,11 @@
login login
password) password)
(define-condition-type 'ftp:error '(error)) (define-condition-type 'ftp-error '(error))
(define ftp:error? (condition-predicate 'ftp:error)) (define ftp-error? (condition-predicate 'ftp-error))
(define (ftp:build-PORT-string sockaddr) (define (ftp-build-PORT-string sockaddr)
(let* ((hst-info (host-info (system-name))) (let* ((hst-info (host-info (system-name)))
(ip-address (car (host-info:addresses hst-info)))) (ip-address (car (host-info:addresses hst-info))))
(receive (hst-address srvc-port) (receive (hst-address srvc-port)
@ -520,14 +520,14 @@
))))) )))))
(define (ftp:send-command connection command . maybe-expected) (define (ftp-send-command connection command . maybe-expected)
(let-optionals* maybe-expected ((expected "2..")) (let-optionals* maybe-expected ((expected "2.."))
(let* ((sock (ftp-connection:command-socket connection)) (let* ((sock (ftp-connection:command-socket connection))
(OUT (socket:outport sock))) (OUT (socket:outport sock)))
(write-string command OUT) (write-string command OUT)
(write-crlf OUT) (write-crlf OUT)
(ftp:log connection (format #f "<- ~a" command)) (ftp-log connection (format #f "<- ~a" command))
(ftp:read-response connection expected)))) (ftp-read-response connection expected))))
;; This is where we check that the server's 3 digit status code ;; This is where we check that the server's 3 digit status code
@ -535,37 +535,37 @@
;; "250", which indicates we are expecting a 250 code from the server, ;; "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 ;; 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 ;; 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 ;; 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 ;; pop3.scm to see how). Since this is implemented as a regexp, you
;; can also specify more complicated acceptable responses of the form ;; 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 ;; "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 ;; message too, but beware that the messages change from server to
;; server. ;; server.
(define (ftp:read-response connection . maybe-expected) (define (ftp-read-response connection . maybe-expected)
(let-optionals* maybe-expected ((expected "2..")) (let-optionals* maybe-expected ((expected "2.."))
(let* ((sock (ftp-connection:command-socket connection)) (let* ((sock (ftp-connection:command-socket connection))
(IN (socket:inport sock)) (IN (socket:inport sock))
(response (read-line IN))) (response (read-line IN)))
(ftp:log connection (format #f "-> ~a" response)) (ftp-log connection (format #f "-> ~a" response))
(or (string-match expected response) (or (string-match expected response)
(signal 'ftp:error response)) (signal 'ftp-error response))
;; handle multi-line responses ;; handle multi-line responses
(if (equal? (string-ref response 3) #\-) (if (equal? (string-ref response 3) #\-)
(let loop ((code (string-append (substring response 0 3) " ")) (let loop ((code (string-append (substring response 0 3) " "))
(line (read-line IN))) (line (read-line IN)))
(ftp:log connection (format #f "-> ~a" line)) (ftp-log connection (format #f "-> ~a" line))
(set! response (string-join (list response line "\n"))) (set! response (string-join (list response line "\n")))
(or (string-match code line) (or (string-match code line)
(loop code (read-line IN))))) (loop code (read-line IN)))))
response))) response)))
(define (ftp:build-command-string str . opt-args) (define (ftp-build-command-string str . opt-args)
(if (string? opt-args) (if (string? opt-args)
(string-join (list str arg)) (string-join (list str arg))
str)) str))
(define (ftp:log connection line) (define (ftp-log connection line)
(let ((LOG (ftp-connection:logfd connection))) (let ((LOG (ftp-connection:logfd connection)))
(and LOG (and LOG
(write-string line LOG) (write-string line LOG)

42
modules.scm
View File

@ -582,7 +582,7 @@
;; ftp.scm is a module for transfering files between networked ;; ftp.scm is a module for transfering files between networked
;; machines using the File Transfer Protocol ;; machines using the File Transfer Protocol
(define-interface ftp-interface (define-interface ftp-obsolete-interface
(export ftp:connect (export ftp:connect
ftp:login ftp:login
ftp:type ftp:type
@ -604,6 +604,45 @@
ftp:append ftp:append
ftp:quot)) ftp:quot))
(define-structure ftp-obsolete ftp-obsolete-interface
(open netrc
scsh
defrec-package
receiving
handle
conditions
signals
error-package
ecm-utilities
string-lib
let-opt
ftp
scheme)
(files ftp-obsolete))
(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
ftp-error?))
(define-structure ftp ftp-interface (define-structure ftp ftp-interface
(open netrc (open netrc
scsh scsh
@ -618,7 +657,6 @@
let-opt let-opt
scheme) scheme)
(files ftp)) (files ftp))
;; pop3.scm is a module for accessing email on a maildrop server, ;; pop3.scm is a module for accessing email on a maildrop server,
;; using the POP3 protocol. ;; using the POP3 protocol.