;;; 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!

(define (ftp-connect host login password passive? . args)
  (let-optionals* args ((logfile #f))
    (let* ((log (cond
		 ((output-port? logfile)
		  logfile)
		 ((string? logfile)
		  (open-output-file logfile
				    (if (file-exists? logfile)
					(bitwise-ior open/write open/append)
					(bitwise-ior open/write open/create))
				    #o600))
		 (else #f)))
	   (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
	       (format #f "~%-- ~a: opened ftp connection to ~a"
		       (date->string (date))
		       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-parse))
	      netrc-record)))))
    (let ((login (or login
		     (netrc-lookup-login (get-netrc-record)
					 (ftp-connection-host-name connection)))))
      (let ((reply
	     (ftp-send-command connection (ftp-build-command-string "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
			      (ftp-build-command-string
			       "PASS"
			       (or password
				   (netrc-lookup-password (get-netrc-record)
							  (ftp-connection-host-name
							   connection))))
			      (exactly-code "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))))
    (string->number (substring reply
			       4 (string-length reply)))))

;; 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
                      (apply ftp-build-command-string "NLST" maybe-dir)
                      (code-with-prefix "1"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (let ((lines (port->lines (socket:inport newsock))))
	(close-socket newsock)
	(close-socket sock)
	(ftp-read-reply connection)
	lines))))

;;: connection [ x string ] -> status
(define (ftp-dir connection . maybe-dir)
  (let* ((sock (ftp-open-data-connection connection)))
    (ftp-send-command connection
                      (apply ftp-build-command-string "LIST" maybe-dir)
                      (code-with-prefix "1"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (let ((lines (port->lines (socket:inport newsock))))
	(close-socket newsock)
	(close-socket sock)
	(ftp-read-reply connection)
	lines))))

(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)
  (let* ((sock (ftp-open-data-connection connection)))
    (ftp-send-command connection
		      (ftp-build-command-string "RETR" remote-file)
                      (exactly-code "150"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (act (socket:inport newsock))
      (close-socket newsock)
      (close-socket sock)
      (ftp-read-reply connection))))

;; 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)
  (let ((sock (ftp-open-data-connection connection)))
    (ftp-send-command connection (ftp-build-command-string "STOR" remote-file)
		      (exactly-code "150"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (act (socket:outport newsock))
      (close-socket newsock)
      (close-socket sock))))

(define (ftp-append connection remote-file act)
  (let ((sock (ftp-open-data-connection connection)))
    (ftp-send-command connection (ftp-build-command-string "APPE" remote-file)
		      (exactly-code "150"))
    (receive (newsock newsockaddr)
	(accept-connection sock)
      (act (socket:outport newsock))
      (close-socket newsock)
      (close-socket sock))))

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