165 lines
4.9 KiB

;;;; 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-1999 Erick Gallesio - I3S-CNRS/ESSI <>
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions. No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;; Author: Erick Gallesio []
;;;; Creation date: 10-Jun-1996 12:22
;;;; Last file update: 3-Sep-1999 19:52 (eg)
(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)
(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)
(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) ",")))
(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)
(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))))
(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)
(socket-shutdown sock)
(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)
(socket-shutdown sock)
(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)
(socket-shutdown sock)
(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)
(socket-shutdown sock)
(provide "ftp")