stk/Lib/ftp.stklos

;;;;
;;;; f t p  . s t k		-- A very incomplete library for ftping file
;;;;				   Error are not (yet) properly detected
;;;;				   A lot of things are missing
;;;;				   (See RFC 959)
;;;;
;;;; Copyright © 1996-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works.  Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.  
;;;; This software is provided ``as is'' without express or implied warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 10-Jun-1996 12:22
;;;; Last file update:  9-Apr-1998 10:46

(require "stklos")
(require "posix")

(define-class <FTP-connection> ()
  ((port   :init-keyword :port :accessor port :initform 21)
   (host   :init-keyword :host :accessor host)
   (echo   :init-keyword :echo :initform display)
   (socket :accessor socket-of)))

;;;;
;;;; Initialize (make the connection)
;;;;
(define-method initialize ((self <FTP-connection>) initargs)
  (next-method)
  (let ((port (slot-ref self 'port))
	(host (slot-ref self 'host)))
    (slot-set! self 'socket (make-client-socket host port))
    (ftp-read-line  self #f)))

;;;;
;;;; ftp-read-line
;;;;
(define-method ftp-read-line ((self <FTP-connection>) echo?)
  (let ((in 	      (socket-input (socket-of self)))
	(analyse-code (lambda (code) (< code 400))))

    (let loop ((srch #f) ; the code we search for multi-line responses
	       (l    (read-line in)))
      (if (eof-object? l)
	  (begin
	    (error "PANIC: End of file encountered. Closing connection.")
	    (socket-shutdown (socket-of self)))
	  (let ((code (string->number (substring l 0 3)))
		(sep  (string-ref l 3))
		(msg  (substring  l 4 (string-length l))))
	    (when echo?
	      ((slot-ref self 'echo) (string-append msg "\n")))
	    (if srch
		;; We are already in a multi-line sequence 
		(if (and (eq? code srch) (eq? sep #\space))
		    (analyse-code code)
		    (loop srch (read-line in)))
		(if (char=? sep #\-)
		    ;; We start a multi-line sequence
		    (loop code (read-line in))
		    (analyse-code code))))))))

;;;;
;;;; ftp-write-line
;;;;
(define-method ftp-write-line ((self <FTP-connection>) l echo?)
  (let ((out (socket-output (socket-of self))))
    (display l out) (newline out) (flush out)
    (ftp-read-line self echo?)))

;;;
;;; Utilities
;;;
(define-method  ftp-data ((self <FTP-connection>) cmd)
  (let* ((s  (make-server-socket 0))
	 (c  (socket-of self))
	 (n  (socket-port-number s))
	 (ip (regexp-replace-all "\\." (socket-local-address c) ",")))

    (if (and (ftp-write-line self (format #f "PORT ~A,~A,~A" ip
					  (quotient n 256) (remainder n 256)) #f)
	     (ftp-write-line self cmd #f))
	;; Transfer seems OK
	(begin
	  (socket-accept-connection s)
	  (let ((in (socket-input s)))
	    (do ((l (read-line in) (read-line in)))
		((eof-object? l))
	      (display l)
	      (newline)))
	  (ftp-read-line self #f))
	;; There something which is not OK (we should be more precise here)
	#f)))

(define-method ftp-data ((self <FTP-connection>) cmd)
  (let* ((s  (make-server-socket 0))
	 (c  (socket-of self))
	 (n  (socket-port-number s))
	 (ip (regexp-replace-all "\\." (socket-local-address c) ",")))
    (and (ftp-write-line self (format #f "PORT ~A,~A,~A" ip
				      (quotient n 256) (remainder n 256)) #f)
	 (ftp-write-line self cmd #f)
	 (socket-accept-connection s)
	 s)))

(define-method ftp-copy ((self <FTP-connection>) from to nowait?)
  (do ((c (read-char from) (read-char from)))
      ((eof-object? c))
    (write-char c to))
  (flush to)
  (close-input-port from)
  (or nowait? (ftp-read-line self #f)))

;;;;==========================================================================
;;;;
;;;; FTP library (only a subpart of a true library)
;;;;
;;;;==========================================================================

(define (ftp-login s user pass)
  (and (ftp-write-line s (format #f "USER ~A" user) #t)
       (ftp-write-line s (format #f "PASS ~A" pass) #t)))
  
(define (ftp-quit s)
  (ftp-write-line s "QUIT" #t)
  (socket-shutdown (socket-of s)))

(define (ftp-chdir s dir)
  (ftp-write-line s (format #f "CWD ~A" dir) #f))

(define (ftp-pwd s)
  (ftp-write-line s "PWD" #t))

(define (ftp-type s mode)
  (ftp-write-line s (format #f "TYPE ~A" mode) #f))

(define (ftp-help s . cmd)
  (ftp-write-line s
     (format #f "HELP~A" (if (null? cmd) "" (string-append " " (car cmd))))
     #t))

(define (ftp-dir s . args)
  (ftp-write-line s "TYPE A" #f)
  (let* ((cmd  (if (null? args) "LIST" (format #f "NLST ~A" (car args))))
	 (sock (ftp-data s cmd)))
    (and sock (ftp-copy s (socket-input sock) (current-output-port) #f))))

(define (ftp-get s file)
  (ftp-write-line s "TYPE I" #f)
  (let* ((cmd (format #f "RETR ~A" file))
	 (sock (ftp-data s cmd)))
    (and sock (ftp-copy s (socket-input sock) (open-output-file file) #f))))

(define (ftp-display s file)
  (ftp-write-line s "TYPE A" #f)
  (let* ((cmd (format #f "RETR ~A" file))
	 (sock (ftp-data s cmd)))
    (and sock (ftp-copy s (socket-input sock) (current-output-port) #f))))

(define (ftp-put s file)
  (ftp-write-line s "TYPE I" #f)
  (let* ((cmd (format #f "STOR ~A" file))
	 (sock (ftp-data s cmd)))
    (and sock (ftp-copy s (open-input-file file) (socket-output sock) #t))))

(provide "ftp")