437 lines
15 KiB
Scheme
437 lines
15 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.
|
|
;;; Copyright (c) 2003 by Mike Sperber <sperber@informatik.uni-tuebingen.de>
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
;; 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.ietf.org/rfc/rfc959.txt
|
|
;;
|
|
;; * /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)
|
|
;;
|
|
;; * XEmacs gets transparent remote file access from EFS.
|
|
;; 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 ============================================================
|
|
;;
|
|
;; * Unix-specific commands such as SITE UMASK, SITE CHMOD
|
|
;; * improved error handling
|
|
|
|
;; 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!
|
|
|
|
(define (ftp-connect host login password passive? . args)
|
|
(let-optionals* args ((log #f))
|
|
(let* ((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
|
|
passive?
|
|
log)))
|
|
(ftp-log connection
|
|
(string-append "-- "
|
|
(date->string (date))
|
|
": opened ftp connection to "
|
|
hostname))
|
|
(ftp-read-reply connection (exactly-code "220")) ; the initial welcome banner
|
|
(ftp-login connection login password)
|
|
connection)))
|
|
|
|
;; Send user information to the remote host. Args are login
|
|
;; and password. If they are not provided, the Netrc module is used to
|
|
;; try to determine a login and password for the server.
|
|
|
|
(define (ftp-login connection login password)
|
|
(let* ((netrc-record #f)
|
|
(get-netrc-record
|
|
(lambda ()
|
|
(cond
|
|
(netrc-record)
|
|
(else
|
|
(set! netrc-record
|
|
(netrc-machine-entry (ftp-connection-host-name connection) #t))
|
|
netrc-record)))))
|
|
(let ((login (or login
|
|
(netrc-entry-login (get-netrc-record)))))
|
|
(let ((reply
|
|
(ftp-send-command connection (build-command "USER" login)
|
|
(lambda (code)
|
|
(or (string=? code "331") ; "User name okay, need password."
|
|
(string=? code "230")))))) ; "User logged in, proceed."
|
|
|
|
(if (string-prefix? "331" reply) ; "User name okay, need password."
|
|
(ftp-send-command connection
|
|
(build-command
|
|
"PASS"
|
|
(or password
|
|
(netrc-entry-password (get-netrc-record))))
|
|
(exactly-code "230")))))))
|
|
|
|
(define-enumerated-type ftp-type :ftp-type
|
|
ftp-type?
|
|
ftp-types
|
|
ftp-type-name
|
|
ftp-type-index
|
|
(binary ascii))
|
|
|
|
(define (ftp-set-type! connection type)
|
|
(let ((ttype (cond
|
|
((eq? type (ftp-type binary)) "I")
|
|
((eq? type (ftp-type ascii)) "A"))))
|
|
(ftp-send-command connection (build-command "TYPE" ttype))
|
|
(values)))
|
|
|
|
(define (ftp-rename connection oldname newname)
|
|
(ftp-send-command connection (build-command "RNFR " oldname)
|
|
(code-with-prefix "35"))
|
|
(ftp-send-command connection (build-command "RNTO" newname)
|
|
(code-with-prefix "25"))
|
|
(values))
|
|
|
|
(define (ftp-delete connection file)
|
|
(ftp-send-command connection (build-command "DELE" file)
|
|
(code-with-prefix "25"))
|
|
(values))
|
|
|
|
;;: connection x string -> status
|
|
(define (ftp-cd connection dir)
|
|
(ftp-send-command connection (build-command "CWD" dir))
|
|
(values))
|
|
|
|
;;: connection -> status
|
|
(define (ftp-cdup connection)
|
|
(ftp-send-command connection "CDUP" (exactly-code "250"))
|
|
(values))
|
|
|
|
;;: on success return the new directory as a string
|
|
(define (ftp-pwd connection)
|
|
(let ((reply (ftp-send-command connection "PWD" (exactly-code "257"))))
|
|
(cond
|
|
((regexp-search (rx (seq bos (= 3 digit) #\space
|
|
(* (~ #\")) #\" (submatch (* (~ #\"))) #\"))
|
|
reply)
|
|
=> (lambda (match)
|
|
(match:substring match 1))))))
|
|
|
|
(define (ftp-rmdir connection dir)
|
|
(ftp-send-command connection (build-command "RMD " dir))
|
|
(values))
|
|
|
|
(define (ftp-mkdir connection dir)
|
|
(ftp-send-command connection (build-command "MKD ~a" dir))
|
|
(values))
|
|
|
|
;; 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)
|
|
|
|
(define (ftp-modification-time connection file)
|
|
(let* ((reply (ftp-send-command connection
|
|
(build-command "MDTM" file)))
|
|
(timestr (substring reply 4 (string-length reply))))
|
|
(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* ((reply (ftp-send-command connection
|
|
(build-command "SIZE" file))))
|
|
(string->number (substring reply
|
|
4 (string-length reply)))))
|
|
|
|
;; Abort the current data transfer. Maybe we should close the data
|
|
;; socket?
|
|
|
|
(define (ftp-abort connection)
|
|
(ftp-send-command connection "ABOR")
|
|
(values))
|
|
|
|
(define (ftp-quit connection)
|
|
(ftp-send-command connection "QUIT" (exactly-code "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).
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (ftp-ls connection . maybe-dir)
|
|
(with-data-connection
|
|
connection
|
|
(lambda ()
|
|
(ftp-send-command connection
|
|
(apply build-command "NLST" maybe-dir)
|
|
(code-with-prefix "1")))
|
|
(lambda (data-socket)
|
|
(port->lines (socket:inport data-socket)))))
|
|
|
|
(define (find-port-arg string)
|
|
(cond
|
|
((regexp-search (rx (: (+ digit) (= 5 (: #\, (+ digit))))) string)
|
|
=> (lambda (match)
|
|
(match:substring match 0)))))
|
|
|
|
(define (ftp-dir connection . maybe-dir)
|
|
(with-data-connection
|
|
connection
|
|
(lambda ()
|
|
(ftp-send-command connection
|
|
(apply build-command "LIST" maybe-dir)
|
|
(code-with-prefix "1")))
|
|
(lambda (data-socket)
|
|
(port->lines (socket:inport data-socket)))))
|
|
|
|
(define (port->lines port)
|
|
(let loop ((reverse-lines '()))
|
|
(let ((line (read-crlf-line port)))
|
|
(if (eof-object? line)
|
|
(reverse reverse-lines)
|
|
(loop (cons line reverse-lines))))))
|
|
|
|
(define (ftp-get connection remote-file act)
|
|
(with-data-connection
|
|
connection
|
|
(lambda ()
|
|
(ftp-send-command connection
|
|
(build-command "RETR" remote-file)
|
|
(exactly-code "150")))
|
|
(lambda (data-socket)
|
|
(act (socket:inport data-socket)))))
|
|
|
|
;; 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".
|
|
|
|
(define (ftp-put connection remote-file act)
|
|
(with-data-connection
|
|
connection
|
|
(lambda ()
|
|
(ftp-send-command connection (build-command "STOR" remote-file)
|
|
(exactly-code "150")))
|
|
(lambda (data-socket)
|
|
(act (socket:outport data-socket)))))
|
|
|
|
(define (ftp-append connection remote-file act)
|
|
(with-data-connection
|
|
connection
|
|
(lambda ()
|
|
(ftp-send-command connection (build-command "APPE" remote-file)
|
|
(exactly-code "150")))
|
|
(lambda (data-socket)
|
|
(act (socket:outport data-socket)))))
|
|
|
|
;; send a command verbatim to the remote server and wait for a
|
|
;; reply.
|
|
|
|
(define (ftp-quot connection cmd)
|
|
(ftp-send-command connection cmd))
|
|
|
|
;; ------------------------------------------------------------------------
|
|
;; no exported procedures below
|
|
|
|
(define (with-data-connection connection command-thunk proc)
|
|
(if (ftp-connection-passive-mode? connection)
|
|
(let* ((pasv-reply (ftp-send-command connection "PASV" (exactly-code "227")))
|
|
(port-arg (find-port-arg pasv-reply)))
|
|
(call-with-values
|
|
(lambda () (parse-port-arg port-arg))
|
|
(lambda (address port)
|
|
(let ((data-socket (create-socket protocol-family/internet
|
|
socket-type/stream)))
|
|
(set-socket-option data-socket level/socket socket/reuse-address #t)
|
|
(connect-socket data-socket
|
|
(internet-address->socket-address
|
|
address port))
|
|
(command-thunk)
|
|
(let ((retval (proc data-socket)))
|
|
(close-socket data-socket)
|
|
(ftp-read-reply connection)
|
|
retval)))))
|
|
|
|
(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)))
|
|
(command-thunk)
|
|
(receive (data-socket data-socket-address)
|
|
(accept-connection sock)
|
|
(let ((retval (proc data-socket)))
|
|
(close-socket data-socket)
|
|
(close-socket sock)
|
|
(ftp-read-reply connection)
|
|
retval)))))
|
|
|
|
;; 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 passive-mode? logfd)
|
|
ftp-connection?
|
|
(host-name ftp-connection-host-name)
|
|
(command-socket ftp-connection-command-socket)
|
|
(passive-mode? ftp-connection-passive-mode?)
|
|
(logfd ftp-connection-logfd))
|
|
|
|
(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)
|
|
(string-append "PORT "
|
|
(format-internet-host-address ip-address ",")
|
|
","
|
|
(format-port srvc-port)))))
|
|
|
|
(define (ftp-send-command connection command . maybe-expected)
|
|
(let* ((sock (ftp-connection-command-socket connection))
|
|
(out (socket:outport sock)))
|
|
(write-string command out)
|
|
(write-crlf out)
|
|
(ftp-log connection (string-append "<- " command))
|
|
(apply ftp-read-reply connection maybe-expected)))
|
|
|
|
(define any-code (lambda (code) #t))
|
|
(define (code-with-prefix prefix)
|
|
(lambda (code)
|
|
(string-prefix? prefix code)))
|
|
(define (exactly-code the-code)
|
|
(lambda (code)
|
|
(string=? code the-code)))
|
|
|
|
;; This is where we check that the server's 3 digit status code
|
|
;; corresponds to what we expected.
|
|
|
|
;; EXPECTED? is a predicate on reply codes. If the server's reply
|
|
;; doesn't satisfy EXPECTED?, we raise an FTP-ERROR.
|
|
|
|
(define (ftp-read-reply connection . maybe-expected)
|
|
(let-optionals* maybe-expected ((expected? (code-with-prefix "2")))
|
|
(let* ((sock (ftp-connection-command-socket connection))
|
|
(in (socket:inport sock))
|
|
(reply (read-crlf-line in))
|
|
(code (substring reply 0 3)))
|
|
(ftp-log connection (string-append "-> " reply))
|
|
(if (not (expected? code))
|
|
(signal 'ftp-error reply))
|
|
;; handle multi-line replies
|
|
(if (char=? (string-ref reply 3) #\-)
|
|
(let ((end-prefix (string-append code " ")))
|
|
(let loop ()
|
|
(let* ((line (read-crlf-line in))
|
|
(reply (string-join (list reply line "\n"))))
|
|
(ftp-log connection (string-append "-> " line))
|
|
(if (string-prefix? end-prefix line)
|
|
reply
|
|
(loop)))))
|
|
reply))))
|
|
|
|
(define (build-command str . opt-args)
|
|
(string-join (cons str opt-args)))
|
|
|
|
(define (ftp-log connection line)
|
|
(cond
|
|
((ftp-connection-logfd connection)
|
|
=> (lambda (log)
|
|
(write-string line log)
|
|
(write-string "\n" log)
|
|
(force-output log)))))
|