sunet/scheme/lib/ftp.scm

;;; 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)
;;
;; * 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 ============================================================
;;
;; * 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))
		       hostname))
      (ftp-read-reply connection (exactly-code "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) any-code)  ; "331"
    (ftp-send-command connection (format #f "PASS ~a" password))))) ; "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) (code-with-prefix "35"))
  (ftp-send-command connection (format #f "RNTO ~a" newname) (code-with-prefix "25")))

;;: connection x string -> status
(define (ftp-delete connection file)
  (ftp-send-command connection (format #f "DELE ~a" file) (code-with-prefix "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" (exactly-code "250")))


;;: 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))))))

;;: 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* ((reply (ftp-send-command connection
				  (format #f "MDTM ~a" 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
				  (format #f "SIZE ~a" file))))
    (and (string? reply)
         (string->number (substring reply
                                    4 (- (string-length reply) 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" (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).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;: 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)
                      (code-with-prefix "1"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (dump (socket:inport newsock))
      (close-socket newsock)
      (close-socket sock)
      (ftp-read-reply connection))))

;;: 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)
                      (code-with-prefix "1"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (dump (socket:inport newsock))
      (close-socket newsock)
      (close-socket sock)
      (ftp-read-reply connection))))


;; 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)
                      (exactly-code "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-reply connection)))
	(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 (exactly-code "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-reply connection)))
	  (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 (exactly-code "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-reply connection)))
	  (close IN)
	  (close-socket sock)
	  status)))))

;; send a command verbatim to the remote server and wait for a
;; reply.
;;: 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)
      (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 (format #f "<- ~a" 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 (format #f "-> ~a" 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 (format #f "-> ~a" line))
		(if (string-prefix? end-prefix line)
		    reply
		    (loop)))))
	  reply))))

(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))))