;;;; vim:ft=lisp ;;;; Touched: <03-Nov-03 09:54:13 IST, madhu> ;;;; - for CLISP under win32. - added reget functionality ;;;; - removed dependency on other packages, added reget/mdtm ;;;; ;;;; CL-FTP is ;;;; Copyright (c) 2002 Matthew Danish. ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; 1. Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; 2. Redistributions in binary form must reproduce the above copyright ;;;; notice, this list of conditions and the following disclaimer in the ;;;; documentation and/or other materials provided with the distribution. ;;;; 3. The name of the author may not be used to endorse or promote products ;;;; derived from this software without specific prior written permission. ;;;; ;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR ;;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, ;;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; FTP client functionality (require 'acl-compat) #+allegro (eval-when (:compile-toplevel :load-toplevel :execute) (require :sock)) ; just in case (defpackage #:org.mapcar.ftp.client (:use #:common-lisp) (:nicknames #:ftp.client #:ftp) (:export #:ftp-connection #:with-ftp-connection #:connect-to-server #:close-connection #:send-list-command #:send-nlst-command #:with-transfer-socket #:call-with-transfer-socket #:ftp-error #:invalid-code #:transient-negative-completion #:permanent-negative-completion #:ftp-error-code #:error-message #:expected #:received #:passive-ftp-p #:code-cut-off-p #:ftp-hostname #:ftp-port #:ftp-username #:ftp-password #:ftp-session-stream #:data-to-string #:retrieve-file #:store-file #:receive-response #:data-ready-p #:retrieve-filename-list #:retrieve-file-info-list ;; madhu #:reget-file #:send-mdtm-command )) (in-package #:org.mapcar.ftp.client) (defun SPLIT-SEQUENCE (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)) ; madhu "Return a list of subsequences in seq delimited by delimiter. ;;; found on cc-lan: ;;; This code was based on Arthur Lemmens' in ;;; ; ;;; If :remove-empty-subseqs is NIL, empty subsequences will be included in the result; otherwise they will be discarded. All other keywords work analogously to those for CL:SUBSTITUTE. In particular, the behaviour of :from-end is possibly different from other versions of this function; :from-end values of NIL and T are equivalent unless :count is supplied. The second return value is an index suitable as an argument to CL:SUBSEQ into the sequence indicating where processing stopped." (let ((len (length seq)) (other-keys (nconc (when test-supplied (list :test test)) (when test-not-supplied (list :test-not test-not)) (when key-supplied (list :key key))))) (unless end (setq end len)) (if from-end (loop for right = end then left for left = (max (or (apply #'position delimiter seq :end right :from-end t other-keys) -1) (1- start)) unless (and (= right (1+ left)) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values (nreverse subseqs) right) else collect (subseq seq (1+ left) right) into subseqs and sum 1 into nr-elts until (< left start) finally (return (values (nreverse subseqs) (1+ left)))) (loop for left = start then (+ right 1) for right = (min (or (apply #'position delimiter seq :start left other-keys) len) end) unless (and (= right left) remove-empty-subseqs) ; empty subseq we don't want if (and count (>= nr-elts count)) ;; We can't take any more. Return now. return (values subseqs left) else collect (subseq seq left right) into subseqs and sum 1 into nr-elts until (>= right end) finally (return (values subseqs right)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (define-condition ftp-error () ((ftp-error-code :initarg :ftp-error-code :initform "\"unspecified\"" :reader ftp-error-code) (error-message :initarg :error-message :initform "\"unspecified\"" :reader error-message)) (:report (lambda (c s) (format s "FTP error ~A raised: ~A" (ftp-error-code c) (error-message c))))) (define-condition invalid-code (ftp-error) ((expected :reader expected :initarg :expected) (received :reader received :initarg :received)) (:report (lambda (c s) (format s "Expected FTP code ~A, got FTP code ~A" (expected c) (received c))))) (define-condition transient-negative-completion (ftp-error) () (:report (lambda (c s) (format s "Received transient error code ~A: ~A" (ftp-error-code c) (error-message c))))) (define-condition permanent-negative-completion (ftp-error) () (:report (lambda (c s) (format s "Received permanent error code ~A: ~A" (ftp-error-code c) (error-message c))))) (defclass ftp-connection () ((hostname :initarg :hostname :reader ftp-hostname) (port :initarg :port :initform 21 :reader ftp-port) (username :initarg :username :initform "anonymous" :reader ftp-username) (password :initarg :password :initform "cl-ftp@cclan.net" :reader ftp-password) (session-stream :initarg :session-stream :initform nil :reader ftp-session-stream) (passive-ftp-p :initarg :passive-ftp-p :initform nil :accessor passive-ftp-p) (code-cut-off-p :initarg :code-cut-off-p :initform t :accessor code-cut-off-p) (socket)))) (defmacro with-ftp-connection-slots ((conn) &body body) `(with-slots (socket hostname port username password session-stream passive-ftp-p code-cut-off-p) ,conn ,@body)) (defmethod print-object ((obj ftp-connection) stream) (with-ftp-connection-slots (obj) (print-unreadable-object (obj stream) (format stream "FTP connection to ~A:~A username: ~A" hostname port username)))) (defun raise-ftp-error (error-code error-msg &key (expected-code nil)) (cond ((and (>= error-code 400) (< error-code 500)) (error 'transient-negative-completion :ftp-error-code error-code :error-message error-msg)) ((and (>= error-code 500) (< error-code 600)) (error 'permanent-negative-completion :ftp-error-code error-code :error-message error-msg)) (expected-code (error 'invalid-code :expected expected-code :received error-code :ftp-error-code error-code :error-message error-msg)) (t (error 'ftp-error :ftp-error-code error-code :error-message error-msg)))) (defun data-to-string (data) (format nil "~{~A~%~}" data)) (defmethod expect-code-or-lose ((conn ftp-connection) (expected-code integer)) (multiple-value-bind (data code) (receive-response conn :block t) (unless (eql code expected-code) (raise-ftp-error code (data-to-string data) :expected-code expected-code)) data)) (defmethod initialize-instance :after ((conn ftp-connection) &rest initargs) (declare (ignorable initargs)) (connect-to-server conn)) (defmethod connect-to-server ((conn ftp-connection)) (with-ftp-connection-slots (conn) (unless (and hostname port (integerp port) (stringp hostname)) (error "You must specify a hostname string and an integer port")) (when (and (slot-boundp conn 'socket) (streamp socket)) (close socket)) (setf socket (ACL-SOCKET:make-socket :format :bivalent ;;madhu?? :remote-host hostname :remote-port port)) (unless socket (error "Error connecting to ~A:~A" hostname port)) (when (and username password (stringp username) (stringp password)) (expect-code-or-lose conn 220) (send-raw-line conn (format nil "USER ~A" username)) (expect-code-or-lose conn 331) (send-raw-line conn (format nil "PASS ~A" password)) (expect-code-or-lose conn 230)) (values))) (defmacro with-ftp-connection ((conn &key hostname port username password passive-ftp-p session-stream (code-cut-off-p t code-cut-off-p-p) (if-failed :error)) &body body) `(let ((,conn (make-instance 'ftp-connection ,@(if hostname `(:hostname ,hostname) ()) ,@(if port `(:port ,port) ()) ,@(if username `(:username ,username) ()) ,@(if password `(:password ,password) ()) ,@(if passive-ftp-p `(:passive-ftp-p ,passive-ftp-p) ()) ,@(if session-stream `(:session-stream ,session-stream) ()) ,@(if code-cut-off-p-p `(:code-cut-off-p ,code-cut-off-p) ())))) (if (null ,conn) (if (eql ,if-failed :error) (error "Connection to ~A:~A failed" ,hostname ,port) ,if-failed) (unwind-protect (progn ,@body) (close-connection ,conn))))) (defmethod log-session ((conn ftp-connection) (data string)) (with-ftp-connection-slots (conn) (when (and session-stream (streamp session-stream)) (write-string data session-stream)) (values))) (defmethod log-session ((conn ftp-connection) (data list)) (log-session conn (data-to-string data))) (defmethod close-connection ((conn ftp-connection)) (with-ftp-connection-slots (conn) (close socket))) (defmethod send-raw-line ((conn ftp-connection) (line string)) (with-ftp-connection-slots (conn) (let ((line (format nil "~A~C~C" line #\Return #\Newline))) (log-session conn line) (write-string line socket)) (force-output socket) (values))) (defmethod data-ready-p ((conn ftp-connection)) (with-ftp-connection-slots (conn) (listen ;;madhu FIXME #+nil ACL-COMPAT.socket::listen1 socket))) (defun clean-ftp-response (data) (mapcar #'(lambda (line) (string-trim '(#\Return #\Newline) line)) data)) (defun maybe-cut-off-code (cut-off-p data code) (if cut-off-p data (mapcar #'(lambda (x) (if (and (> (length x) 3) (eql (parse-integer x :end 3 :junk-allowed t) code)) (subseq x 4) x)) data))) (defmethod receive-response ((conn ftp-connection) &key (block nil)) (with-ftp-connection-slots (conn) (when (and (not block) (not (data-ready-p conn))) (return-from receive-response nil)) (let* ((initial-line (read-line socket)) (ftp-code (parse-integer initial-line :end 3)) (continue-p (char= (char initial-line 3) #\-)) (lines (list (if code-cut-off-p (subseq initial-line 4) initial-line)))) (when continue-p ;; madhu (loop for line = (read-line socket) for line-length = (length line) for line-code = (when (> line-length 3) (parse-integer line :end 3 :junk-allowed t)) while continue-p ; madhu moved while clause here do (push (if (and code-cut-off-p (eql line-code ftp-code)) (subseq line 4) ;; cut-off the code, if present line) lines) ;; continue until reaching a line that begins with the code ;; and has a #\Space after it (when (and (eql line-code ftp-code) (char= #\Space (char line 3))) (setf continue-p nil))) ) (let ((data (clean-ftp-response (nreverse lines)))) (log-session conn data) (values (maybe-cut-off-code code-cut-off-p data ftp-code) ftp-code))))) (defmethod send-port-command ((conn ftp-connection) (ip string) (port-num integer)) (multiple-value-bind (quot rem) (truncate port-num 256) (send-raw-line conn (format nil "PORT ~A,~A,~A" (substitute #\, #\. ip) quot rem)))) (defmethod receive-pasv-response ((conn ftp-connection)) (with-ftp-connection-slots (conn) (multiple-value-bind (data code) (receive-response conn :block t) (unless (eql code 227) (raise-ftp-error code (data-to-string data) :expected-code 227)) (let ((start (position #\( (first data) :from-end t)) (end (position #\) (first data) :from-end t))) (unless (and start end) (error "Unable to parse PASV response")) (let ((numbers (split-sequence #\, (first data) :start (1+ start) :end end))) (values (format nil "~{~A~^.~}" (subseq numbers 0 4)) (+ (ash (parse-integer (fifth numbers)) 8) (parse-integer (sixth numbers))))))))) (defmethod setup-port ((conn ftp-connection) &key (format :binary)) (with-ftp-connection-slots (conn) (let ((server-socket (loop for p = (+ 1025 (random 10000)) for s = (ignore-errors (ACL-SOCKET:make-socket :connect :passive :local-port p :format format)) when s return s)) (local-ip (ACL-SOCKET:ipaddr-to-dotted (ACL-SOCKET:local-host socket)))) (send-port-command conn local-ip (ACL-SOCKET:local-port server-socket)) server-socket))) (defmethod establish-data-transfer ((conn ftp-connection) (command string) &key (rest nil) (type :binary)) (with-ftp-connection-slots (conn) (send-raw-line conn (format nil "TYPE ~A" (ecase type ((:binary :image) "I") (:ascii "A")))) (expect-code-or-lose conn 200) (cond (passive-ftp-p (send-raw-line conn "PASV") (multiple-value-bind (dtp-hostname dtp-port) (receive-pasv-response conn) (let ((data-socket (ACL-SOCKET:make-socket :remote-host dtp-hostname :remote-port dtp-port :format (ecase type ((:binary :image) :binary) (:ascii :text))))) (when (and rest (integerp rest)) (send-raw-line conn (format nil "REST ~A" rest))) (send-raw-line conn command) data-socket))) (t (let ((server-socket (setup-port conn :format (ecase type ((:binary :image) :binary) (:ascii :text))))) (unwind-protect (progn (when (and rest (integerp rest)) (send-raw-line conn (format nil "REST ~A" rest))) (expect-code-or-lose conn 200) (send-raw-line conn command) (ACL-SOCKET:accept-connection server-socket)) (close server-socket))))))) (defmethod flush-response ((conn ftp-connection)) (loop while (receive-response conn))) (defmethod call-with-transfer-socket ((conn ftp-connection) (command string) (fn function) &rest args) (flush-response conn) (let ((transfer-socket (apply #'establish-data-transfer conn command args))) (unwind-protect (funcall fn transfer-socket) (progn (close transfer-socket) (loop (multiple-value-bind (data code) (receive-response conn :block t) ;;madhu: added block t (declare (ignorable data)) (when (and (integerp code) (eql code 226)) (return-from call-with-transfer-socket t)) (when (and (integerp code) (>= code 500)) (return-from call-with-transfer-socket nil)) #+nil ;; (when (null code) (warn "madhu: receive response returned nil. bailing") (return-from call-with-transfer-socket nil)) )))))) (defmacro with-transfer-socket ((socket conn command &rest args) &body body) `(call-with-transfer-socket ,conn ,command #'(lambda (,socket) ,@body) ,@args)) (defmethod send-list-command ((conn ftp-connection) (output null) &optional (pathname ".")) (with-output-to-string (s) (send-list-command conn s pathname))) (defmethod send-list-command ((conn ftp-connection) (output t) &optional (pathname ".")) (send-list-command conn *standard-output* pathname)) (defmethod send-list-command ((conn ftp-connection) (output stream) &optional (pathname ".")) (flet ((read-all (s) (loop (handler-case (write-line (read-line s) output) (end-of-file () (return (values))))))) (with-transfer-socket (s conn (format nil "LIST ~A" pathname) :type :ascii) (read-all s)))) (defmethod send-nlst-command ((conn ftp-connection) (output null) &optional (pathname ".")) (with-output-to-string (s) (send-nlst-command conn s pathname))) (defmethod send-nlst-command ((conn ftp-connection) (output t) &optional (pathname ".")) (send-nlst-command conn *standard-output* pathname)) (defmethod send-nlst-command ((conn ftp-connection) (output stream) &optional (pathname ".")) (flet ((read-all (s) #+nil (loop (handler-case (write-line (read-line s) output) (end-of-file () (return (values))))))) (with-transfer-socket (s conn (format nil "NLST ~A" pathname) :type :ascii) (read-all s)))) (defmethod retrieve-filename-list ((conn ftp-connection) &optional (pathname ".")) (let* ((data (send-nlst-command conn nil pathname)) (split-data (split-sequence #\Newline data :remove-empty-subseqs t))) (mapcar #'(lambda (x) (string-trim '(#\Return) x)) split-data))) (defmethod retrieve-file-info-list ((conn ftp-connection) &optional (pathname ".")) (let ((names (retrieve-filename-list conn pathname)) (file-info-list nil) (orig-dir (send-pwd-command conn)) (base-dir nil)) (send-cwd-command conn pathname) (setf base-dir (send-pwd-command conn)) (unwind-protect (dolist (name names file-info-list) (handler-case (progn (send-cwd-command conn name) (push (list :directory name) file-info-list)) (ftp-error () (push (list :file name) file-info-list))) (send-cwd-command conn base-dir)) (send-cwd-command conn orig-dir)))) (defmethod retrieve-file ((conn ftp-connection) (remote-filename string) local-filename &key (type :binary) (rest nil)) (with-open-file (local-stream local-filename :direction :output :element-type (ecase type ((:binary :image) '(unsigned-byte 8)) (:ascii 'character))) (retrieve-file conn remote-filename local-stream :type type :rest rest))) (defmethod retrieve-file ((conn ftp-connection) (remote-filename string) (local-stream stream) &key (type :binary) (rest nil)) (with-transfer-socket (s conn (format nil "RETR ~A" remote-filename) :type type :rest rest) (handler-case (ecase type ((:binary :image) (loop (write-byte (read-byte s) local-stream))) (:ascii (loop (write-char (read-char s) local-stream)))) (end-of-file () (values))))) (defmethod store-file ((conn ftp-connection) local-filename (remote-filename string) &key (type :binary) (rest nil)) (with-open-file (local-stream local-filename :direction :input :element-type (ecase type ((:binary :image) '(unsigned-byte 8)) (:ascii 'character))) (store-file conn local-stream remote-filename :type type :rest rest))) (defmethod store-file ((conn ftp-connection) (local-stream stream) (remote-filename string) &key (type :binary) (rest nil)) (with-transfer-socket (s conn (format nil "STOR ~A" remote-filename) :type type :rest rest) (handler-case (ecase type ((:binary :image) (loop (write-byte (read-byte local-stream) s))) (:ascii (loop (write-char (read-char local-stream) s)))) (end-of-file () (values))))) (defmacro def-simple-command (cmd (conn &rest args) &body body) (let ((name (intern (format nil "SEND-~A-COMMAND" cmd)))) `(progn (defmethod ,name ((,conn ftp-connection) ,@args) (flush-response ,conn) ,@body) (export ',name)))) (def-simple-command size (conn (remote-filename string)) (send-raw-line conn (format nil "SIZE ~A" remote-filename)) (parse-integer (first (expect-code-or-lose conn 213)))) (def-simple-command cwd (conn (remote-dir string)) (send-raw-line conn (if (string-equal remote-dir "..") "CDUP" (format nil "CWD ~A" remote-dir))) (expect-code-or-lose conn 250)) (def-simple-command cdup (conn) (send-raw-line conn "CDUP") (expect-code-or-lose conn 250)) (defun parse-257-response (string) (let ((start (1+ (position #\" string))) (last (1- (length string)))) (with-output-to-string (out) (do ((i start (1+ i))) ((>= i last) (values)) (if (char= (char string i) #\") (cond ((char= (char string (1+ i)) #\") (write-char #\" out) (incf i)) (t (return (values)))) (write-char (char string i) out)))))) (def-simple-command pwd (conn) (send-raw-line conn "PWD") (parse-257-response (data-to-string (expect-code-or-lose conn 257)))) (def-simple-command mkd (conn (dir-name string)) (send-raw-line conn (format nil "MKD ~A" dir-name)) (parse-257-response (data-to-string (expect-code-or-lose conn 257)))) ;;; ;;; madhu (defmethod reget-file ((conn ftp-connection) (remote-filename string) local-filename &key (type :binary)) (when (eq type :ascii) (error "reget fails on ascii transfers!")) (with-open-file (local-stream local-filename :direction :output :if-exists :append :if-does-not-exist :create :element-type (ecase type ((:binary :image) '(unsigned-byte 8)) (:ascii (warn "REGET: untested on ASCII") 'character))) (unless (< (file-length local-stream) (send-SIZE-command conn remote-filename)) (warn "REGET: localfile bigger than remote file")) (retrieve-file conn remote-filename local-stream :type type :rest (file-length local-stream)))) (def-simple-command mdtm (conn (remote-filename string)) (send-raw-line conn (format nil "MDTM ~A" remote-filename)) (let ((response (expect-code-or-lose conn 213))) response))