463 lines
18 KiB
Scheme
463 lines
18 KiB
Scheme
;;; ftp.scm -- an FTP client library for the Scheme Shell
|
|
|
|
;;; This file is part of the Scheme Untergrund Networking package.
|
|
|
|
;;; Copyright (c) 1998 by Eric Marsden.
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
;;; 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)
|
|
|
|
|
|
;;; Related work ======================================================
|
|
;;
|
|
;; * rfc959 describes the FTP protocol; see
|
|
;; http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
|
|
;;
|
|
;; * /anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz is a
|
|
;; library similar to this one, written in C, by Thomas Pfau
|
|
;;
|
|
;; * FTP.pm is a Perl module with similar functionality (available
|
|
;; from http://www.perl.com/CPAN)
|
|
;;
|
|
;; * Emacs gets transparent remote file access from ange-ftp.el by
|
|
;; Ange Norman. However, it cheats by using /usr/bin/ftp
|
|
;;
|
|
;; * Siod (a small-footprint Scheme implementation by George Carette)
|
|
;; comes with a file ftp.scm with a small subset of these functions
|
|
;; defined
|
|
|
|
|
|
;;; TODO ============================================================
|
|
;;
|
|
;; * handle passive mode and firewalls
|
|
;; * Unix-specific commands such as SITE UMASK, SITE CHMOD
|
|
;; * object-based interface? (like SICP message passing)
|
|
;; * improved error handling
|
|
;; * a lot of the calls to format could be replaced by calls to
|
|
;; string-join. Maybe format is easier to read?
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Communication is initiated by the client. The server responds to
|
|
;; each request with a three digit status code and an explanatory
|
|
;; message, and occasionally with data (which is sent via a separate,
|
|
;; one-off channel). The client starts by opening a command connection
|
|
;; to a well known port on the server machine. Messages send to the
|
|
;; server are of the form
|
|
;;
|
|
;; CMD [ <space> arg ] <CR> <LF>
|
|
;;
|
|
;; Replies from the server are of the form
|
|
;;
|
|
;; xyz <space> Informative message <CR> <LF>
|
|
;;
|
|
;; where xyz is a three digit code which indicates whether the
|
|
;; operation succeeded or not, whether the server is waiting for more
|
|
;; data, etc. The server may also send multiline messages of the form
|
|
;;
|
|
;; xyz- <space> Start of multiline message <CR> <LF>
|
|
;; [ <space>+ More information ]* <CR> <LF>
|
|
;; xyz <space> End of multiline message <CR> <LF>
|
|
;;
|
|
;; Some of the procedures in this module extract useful information
|
|
;; from the server's reply, such as the size of a file, or the name of
|
|
;; the directory we have moved to. These procedures return either the
|
|
;; extracted information, or #f to indicate failure. Other procedures
|
|
;; return a "status", which is either the server's reply as a string,
|
|
;; or #f to signify failure.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; beware, the log file contains password information!
|
|
;;: string [ x string x port] -> connection
|
|
(define (ftp-connect host . args)
|
|
(let-optionals* args ((logfile #f))
|
|
(let* ((LOG (and logfile
|
|
(open-output-file logfile
|
|
(if (file-exists? logfile)
|
|
(bitwise-ior open/write open/append)
|
|
(bitwise-ior open/write open/create))
|
|
#o600)))
|
|
(hst-info (host-info host))
|
|
(hostname (host-info:name hst-info))
|
|
(srvc-info (service-info "ftp" "tcp"))
|
|
(sock (socket-connect protocol-family/internet
|
|
socket-type/stream
|
|
hostname
|
|
(service-info:port srvc-info)))
|
|
(connection (make-ftp-connection hostname
|
|
sock
|
|
LOG "" "")))
|
|
(ftp-log connection
|
|
(format #f "~%-- ~a: opened ftp connection to ~a"
|
|
(date->string (date)) ; doesn't seem to be buggy in v0.6
|
|
;"Dummy date" ; (format-time-zone) is buggy in v0.5.1
|
|
hostname))
|
|
(ftp-read-response connection "220") ; the initial welcome banner
|
|
connection)))
|
|
|
|
;; Send user information to the remote host. Args are optional login
|
|
;; and password. If they are not provided, the Netrc module is used to
|
|
;; try to determine a login and password for the server. If not found we
|
|
;; default to login "anonymous" with password user@host.
|
|
;;: connection [ x string x password ] -> status
|
|
(define (ftp-login connection . args)
|
|
(let ((netrc-record (netrc-parse)))
|
|
(let-optionals* args
|
|
((login
|
|
(netrc-lookup-login netrc-record
|
|
(ftp-connection-host-name connection)))
|
|
(password
|
|
(netrc-lookup-password netrc-record
|
|
(ftp-connection-host-name connection))))
|
|
(set-ftp-connection-login! connection login)
|
|
(set-ftp-connection-password! connection password)
|
|
(ftp-send-command connection (format #f "USER ~a" login) "...") ; "331"
|
|
(ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230"
|
|
|
|
;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
|
|
;; sent verbatim
|
|
;;: connection x symbol|string -> status
|
|
(define (ftp-type connection type)
|
|
(let ((ttype (cond
|
|
((string? type) type)
|
|
((eq? type 'binary) "I")
|
|
((or (eq? type 'ascii)
|
|
(eq? type 'text)) "A")
|
|
(else
|
|
(call-error "type must be one of 'binary or 'text or 'ascii" ftp-type type)))))
|
|
(ftp-send-command connection (format #f "TYPE ~a" ttype))))
|
|
|
|
;;: connection x string x string -> status
|
|
(define (ftp-rename connection oldname newname)
|
|
(ftp-send-command connection (format #f "RNFR ~a" oldname) "35.")
|
|
(ftp-send-command connection (format #f "RNTO ~a" newname) "25."))
|
|
|
|
;;: connection x string -> status
|
|
(define (ftp-delete connection file)
|
|
(ftp-send-command connection (format #f "DELE ~a" file) "25."))
|
|
|
|
;;: connection x string -> status
|
|
(define (ftp-cd connection dir)
|
|
(ftp-send-command connection (format #f "CWD ~a" dir)))
|
|
|
|
;;: connection -> status
|
|
(define (ftp-cdup connection)
|
|
(ftp-send-command connection "CDUP" "250"))
|
|
|
|
|
|
;;: on success return the new directory as a string
|
|
(define (ftp-pwd connection)
|
|
(let* ((response (ftp-send-command connection "PWD" "2..")) ;; 257
|
|
(match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response ""))))
|
|
(match:substring match 1)))
|
|
|
|
;;: connection x string -> status
|
|
(define (ftp-rmdir connection dir)
|
|
(ftp-send-command connection (format #f "RMD ~a" dir)))
|
|
|
|
;;: connection x string -> status
|
|
(define (ftp-mkdir connection dir)
|
|
(ftp-send-command connection (format #f "MKD ~a" dir)))
|
|
|
|
;; On success return a Scsh date record. This message is not part of
|
|
;; rfc959 but seems to be supported by many ftp servers (it's useful
|
|
;; for mirroring)
|
|
;;: connection x string -> date
|
|
(define (ftp-modification-time connection file)
|
|
(let* ((response (ftp-send-command connection
|
|
(format #f "MDTM ~a" file)))
|
|
(match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response "")))
|
|
(timestr (and match (match:substring match 1))))
|
|
(and timestr
|
|
(let ((year (substring timestr 0 4))
|
|
(month (substring timestr 4 6))
|
|
(mday (substring timestr 6 8))
|
|
(hour (substring timestr 8 10))
|
|
(min (substring timestr 10 12))
|
|
(sec (substring timestr 12 14)))
|
|
(make-date (string->number sec)
|
|
(string->number min)
|
|
(string->number hour)
|
|
(string->number mday)
|
|
(string->number month)
|
|
(- (string->number year) 1900))))))
|
|
|
|
;; On success return the size of the file in bytes.
|
|
;;: connection x string -> integer
|
|
(define (ftp-size connection file)
|
|
(let* ((response (ftp-send-command connection
|
|
(format #f "SIZE ~a" file)
|
|
"2..")))
|
|
(and (string? response)
|
|
(string->number (substring response
|
|
4 (- (string-length response) 1))))))
|
|
|
|
;; Abort the current data transfer. Maybe we should close the data
|
|
;; socket?
|
|
;;: connection -> status
|
|
(define (ftp-abort connection)
|
|
(ftp-send-command connection "ABOR"))
|
|
|
|
;;: connection -> status
|
|
(define (ftp-quit connection)
|
|
(ftp-send-command connection "QUIT" "221")
|
|
(close-socket (ftp-connection-command-socket connection)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; The following commands require the use of a data connection as well
|
|
;; as the command connection. The command and the server's reply are
|
|
;; transmitted via the command connection, while the data is
|
|
;; transmitted via the data connection (you could have guessed that,
|
|
;; right?).
|
|
;;
|
|
;; The data socket is created by the client, who sends a PORT command
|
|
;; to the server to indicate on which port it is ready to accept a
|
|
;; connection. The port command specifies an IP number and a port
|
|
;; number, in the form of 4+2 comma-separated bytes. The server then
|
|
;; initiates the data transfer. A fresh data connection is created for
|
|
;; each data transfer (unlike the command connection which stays open
|
|
;; during the entire conversation with the server).
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;: connection [ x string ] -> status
|
|
(define (ftp-ls connection . maybe-dir)
|
|
(let* ((sock (ftp-open-data-connection connection)))
|
|
(ftp-send-command connection
|
|
(ftp-build-command-string "NLST" maybe-dir)
|
|
"1..")
|
|
(receive (newsock newsockaddr)
|
|
(accept-connection sock)
|
|
(dump (socket:inport newsock))
|
|
(close-socket newsock)
|
|
(close-socket sock)
|
|
(ftp-read-response connection "2.."))))
|
|
|
|
;;: connection [ x string ] -> status
|
|
(define (ftp-dir connection . maybe-dir)
|
|
(let* ((sock (ftp-open-data-connection connection)))
|
|
(ftp-send-command connection
|
|
(ftp-build-command-string "LIST" maybe-dir)
|
|
"1..")
|
|
(receive (newsock newsockaddr)
|
|
(accept-connection sock)
|
|
(dump (socket:inport newsock))
|
|
(close-socket newsock)
|
|
(close-socket sock)
|
|
(ftp-read-response connection "2.."))))
|
|
|
|
|
|
;; maybe-local may be a filename to which the data should be written,
|
|
;; or #t to write data to stdout (to current-output-port to be more
|
|
;; precise), or #f to stuff the data in a string (which is returned),
|
|
;; or nothing to output to a local file with the same name as the
|
|
;; remote file.
|
|
;;: connection x string [x string | #t | #f] -> status | string
|
|
(define (ftp-get connection remote-file . maybe-local)
|
|
(let* ((sock (ftp-open-data-connection connection))
|
|
(local (if (pair? maybe-local)
|
|
(car maybe-local)
|
|
'empty))
|
|
(OUT (cond ((string? local) (open-output-file local))
|
|
((eq? local #t) (current-output-port))
|
|
((eq? local #f) (make-string-output-port))
|
|
(else
|
|
(open-output-file remote-file)))))
|
|
(ftp-send-command connection
|
|
(format #f "RETR ~a" remote-file)
|
|
"150")
|
|
(receive (newsock newsockaddr)
|
|
(accept-connection sock)
|
|
(with-current-output-port OUT
|
|
(dump (socket:inport newsock)))
|
|
(close-socket newsock)
|
|
(close-socket sock)
|
|
(let ((status (ftp-read-response connection "2..")))
|
|
(if (string? local) (close OUT))
|
|
(if (eq? local #f)
|
|
(string-output-port-output OUT)
|
|
status)))))
|
|
|
|
|
|
;; FIXME: should have an optional argument :rename which defaults to
|
|
;; false, which would make us upload to a temporary name and rename at
|
|
;; the end of the upload. This atomicity is important for ftp or http
|
|
;; servers which are serving a load, and to avoid problems with "no
|
|
;; space on device".
|
|
|
|
;; optional argument maybe-remote-file is the name under which we wish
|
|
;; the file to appear on the remote machine. If omitted the file takes
|
|
;; the same name on the FTP server as on the local host.
|
|
;;: connection x string [ x string ] -> status
|
|
(define (ftp-put connection local-file . maybe-remote-file)
|
|
(let-optionals* maybe-remote-file ((remote-file #f))
|
|
(let* ((sock (ftp-open-data-connection connection))
|
|
(IN (open-input-file local-file))
|
|
(cmd (format #f "STOR ~a" (or remote-file local-file))))
|
|
(ftp-send-command connection cmd "150")
|
|
(receive (newsock newsockaddr)
|
|
(accept-connection sock)
|
|
(with-current-output-port (socket:outport newsock) (dump IN))
|
|
(close (socket:outport newsock)) ; send the server EOF
|
|
(close-socket newsock)
|
|
(let ((status (ftp-read-response connection "2..")))
|
|
(close IN)
|
|
(close-socket sock)
|
|
status)))))
|
|
|
|
;;: connection x string [x string] -> status
|
|
(define (ftp-append connection local-file . maybe-remote-file)
|
|
(let-optionals* maybe-remote-file ((remote-file #f))
|
|
(let* ((sock (ftp-open-data-connection connection))
|
|
(IN (open-input-file local-file))
|
|
(cmd (format #f "APPE ~a" (or remote-file local-file))))
|
|
(ftp-send-command connection cmd "150")
|
|
(receive (newsock newsockaddr)
|
|
(accept-connection sock)
|
|
(with-current-output-port (socket:outport newsock)
|
|
(dump IN))
|
|
(close (socket:outport newsock)) ; send the server EOF
|
|
(close-socket newsock)
|
|
(let ((status (ftp-read-response connection "2..")))
|
|
(close IN)
|
|
(close-socket sock)
|
|
status)))))
|
|
|
|
;; send a command verbatim to the remote server and wait for a
|
|
;; response.
|
|
;;: connection x string -> status
|
|
(define (ftp-quot connection cmd)
|
|
(ftp-send-command connection cmd))
|
|
|
|
|
|
;; ------------------------------------------------------------------------
|
|
;; no exported procedures below
|
|
|
|
(define (ftp-open-data-connection connection)
|
|
(let* ((sock (create-socket protocol-family/internet
|
|
socket-type/stream))
|
|
(sockaddr (internet-address->socket-address
|
|
internet-address/any
|
|
0))) ; 0 to accept any port
|
|
(set-socket-option sock level/socket socket/reuse-address #t)
|
|
(set-socket-option sock level/socket socket/linger 120)
|
|
(bind-socket sock sockaddr)
|
|
(listen-socket sock 0)
|
|
(ftp-send-command connection ; send PORT command
|
|
(ftp-build-PORT-string (socket-local-address sock)))
|
|
sock))
|
|
|
|
|
|
|
|
;; TODO: Unix-specific commands
|
|
;; SITE UMASK 002
|
|
;; SITE IDLE 60
|
|
;; SITE CHMOD 755 filename
|
|
;; SITE HELP
|
|
|
|
|
|
|
|
;; We cache the login and password to be able to relogin automatically
|
|
;; if we lose the connection (a la ange-ftp). Not implemented.
|
|
(define-record-type ftp-connection :ftp-connection
|
|
(make-ftp-connection host-name command-socket logfd login password)
|
|
ftp-connection?
|
|
(host-name ftp-connection-host-name)
|
|
(command-socket ftp-connection-command-socket)
|
|
(logfd ftp-connection-logfd)
|
|
(login ftp-connection-login set-ftp-connection-login!)
|
|
(password ftp-connection-password set-ftp-connection-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-crlf-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-crlf-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-crlf-line IN)))))
|
|
response)))
|
|
|
|
|
|
(define (ftp-build-command-string str . opt-args)
|
|
(if (string? opt-args)
|
|
(string-join (list str arg))
|
|
str))
|
|
|
|
(define (ftp-log connection line)
|
|
(let ((LOG (ftp-connection-logfd connection)))
|
|
(and LOG
|
|
(write-string line LOG)
|
|
(write-string "\n" LOG)
|
|
(force-output LOG))))
|