├── LICENSE ├── README.org ├── cl-ftp.asd ├── ftp.asd ├── ftp.lisp └── simple-client.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2002 Matthew Danish. 2 | Copyright © 2009 Hans Hübner 3 | Copyright © 2015 pinterface 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. The name of the author may not be used to endorse or promote products 15 | derived from this software without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 18 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 19 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 20 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 21 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 22 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 26 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * Overview 2 | 3 | CL-FTP is a library which provides FTP client functionality to a Common Lisp 4 | program. CL-FTP uses the USOCKET package for network sockets and the 5 | SPLIT-SEQUENCE package for some parsing needs. 6 | 7 | * Examples 8 | 9 | #+begin_src lisp 10 | (with-ftp-connection (conn :hostname "foo") 11 | (retrieve-file conn "bar" "baz")) 12 | #+end_src 13 | 14 | Further examples should be included with your copy of this software. See 15 | simple-client.lisp for a simple FTP client written with CL-FTP. 16 | 17 | * #'RETRIEVE-FILE / #'STORE-FILE hang or don't work 18 | 19 | * Short answer :: Use passive FTP. 20 | 21 | * Long answer :: FTP is something of a weird protocol, and this tends to trip 22 | people up—FTP opens up two connections, one for commands, and one for data 23 | (file transfers). The data channel can be opened in two different ways: in 24 | "active" mode (the default), the client tells the server "hey, connect to me 25 | on port X", and then the server actually opens the connection to the client; 26 | in "passive" mode, the client connects to the server. 27 | 28 | As you might imagine, active mode does not play well with NAT or firewalls, 29 | and this is usually the problem when commands work, but files fail to 30 | download. Most likely, including =:passive-ftp-p t= in your 31 | =WITH-FTP-CONNECTION= or =(make-instance 'ftp-connection)= form will get you 32 | going. 33 | 34 | * License 35 | 36 | This software, and documentation, is copyright various authors. Redistribution 37 | and modification is permitted under a MIT-style license. See the LICENSE file 38 | for more details. 39 | -------------------------------------------------------------------------------- /cl-ftp.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; See LICENSE file for copyright details. 3 | 4 | (asdf:defsystem "cl-ftp" 5 | :name "cl-ftp" 6 | :author "Matthew Danish " 7 | :version "1.6.1" 8 | :maintainer "pinterface " 9 | :licence "MIT/X style" 10 | :description "FTP library" 11 | :long-description "Provides FTP client functionality" 12 | :components ((:file "ftp")) 13 | :depends-on (split-sequence usocket)) 14 | -------------------------------------------------------------------------------- /ftp.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; Original Author: Matthew Danish 3 | ;;;; Maintainer: pinterface 4 | ;;;; usocket Conversion: Hans Hübner 5 | ;;;; See LICENSE file for copyright details. 6 | 7 | (asdf:defsystem ftp 8 | :name "cl-ftp" 9 | :author "Matthew Danish " 10 | :version "1.6.1" 11 | :maintainer "pinterface " 12 | :licence "MIT/X style" 13 | :description "FTP library" 14 | :long-description "Provides FTP client functionality" 15 | :components () 16 | :depends-on (cl-ftp)) 17 | 18 | #+nil 19 | (when (ignore-errors (find-class 'asdf:load-compiled-op)) 20 | (defmethod perform :after ((op asdf:load-compiled-op) (c (eql (asdf:find-system 'ftp)))) 21 | (pushnew :ftp cl:*features*))) 22 | -------------------------------------------------------------------------------- /ftp.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; Authors: 3 | ;;;; * Matthew Danish 4 | ;;;; * Hans Hübner 5 | ;;;; See LICENSE file for copyright details. 6 | ;;;; FTP client functionality 7 | 8 | (defpackage #:org.mapcar.ftp.client 9 | (:use #:common-lisp 10 | #:split-sequence 11 | #:usocket) 12 | (:nicknames #:ftp.client #:ftp) 13 | (:export #:ftp-connection 14 | #:with-ftp-connection 15 | #:connect-to-server 16 | #:close-connection 17 | #:send-list-command 18 | #:send-nlst-command 19 | #:with-transfer-socket 20 | #:call-with-transfer-socket 21 | #:ftp-error 22 | #:invalid-code 23 | #:transient-negative-completion 24 | #:permanent-negative-completion 25 | #:ftp-error-code 26 | #:error-message 27 | #:expected 28 | #:received 29 | #:passive-ftp-p 30 | #:code-cut-off-p 31 | #:ftp-hostname 32 | #:ftp-port 33 | #:ftp-username 34 | #:ftp-password 35 | #:ftp-session-stream 36 | #:data-to-string 37 | #:retrieve-file 38 | #:store-file 39 | #:receive-response 40 | #:data-ready-p 41 | #:retrieve-filename-list 42 | #:retrieve-file-info-list)) 43 | 44 | (in-package #:org.mapcar.ftp.client) 45 | 46 | (define-condition ftp-error () 47 | ((ftp-error-code :initarg :ftp-error-code 48 | :initform "\"unspecified\"" 49 | :reader ftp-error-code 50 | :documentation "Code associated with message") 51 | (error-message :initarg :error-message 52 | :initform "\"unspecified\"" 53 | :reader error-message 54 | :documentation "FTP server's error message")) 55 | (:report (lambda (c s) 56 | (format s "FTP error ~A raised: ~A" 57 | (ftp-error-code c) 58 | (error-message c))))) 59 | 60 | (define-condition invalid-code (ftp-error) 61 | ((expected :reader expected :initarg :expected 62 | :documentation "Expected code") 63 | (received :reader received :initarg :received 64 | :documentation "Received code")) 65 | (:report (lambda (c s) 66 | (format s "Expected FTP code ~A, got FTP code ~A" 67 | (expected c) 68 | (received c))))) 69 | 70 | (define-condition transient-negative-completion (ftp-error) 71 | () 72 | (:report (lambda (c s) 73 | (format s "Received transient error code ~A: ~A" 74 | (ftp-error-code c) 75 | (error-message c)))) 76 | (:documentation "Signalled when a transient error is received from the FTP server. This means that the input was fine, but something else went wrong. Feel free to resend.")) 77 | 78 | (define-condition permanent-negative-completion (ftp-error) 79 | () 80 | (:report (lambda (c s) 81 | (format s "Received permanent error code ~A: ~A" 82 | (ftp-error-code c) 83 | (error-message c)))) 84 | (:documentation "Signalled when a permanent error is received from the FTP server. This means that the input was not acceptable and should not be re-sent.")) 85 | 86 | (defclass ftp-connection () 87 | ((hostname :initarg :hostname 88 | :reader ftp-hostname 89 | :documentation "The remote hostname") 90 | (port :initarg :port :initform 21 91 | :reader ftp-port 92 | :documentation "The remote port") 93 | (username :initarg :username :initform "anonymous" 94 | :reader ftp-username 95 | :documentation "The login username") 96 | (password :initarg :password :initform "cl-ftp@cclan.net" 97 | :reader ftp-password 98 | :documentation "The login password") 99 | (session-stream :initarg :session-stream :initform nil 100 | :reader ftp-session-stream 101 | :documentation "Send FTP session output to this stream, if non-nil") 102 | (passive-ftp-p :initarg :passive-ftp-p :initform nil 103 | :accessor passive-ftp-p 104 | :documentation "Use passive FTP if non-nil") 105 | (code-cut-off-p :initarg :code-cut-off-p :initform t 106 | :accessor code-cut-off-p 107 | :documentation "When non-nil, cut-off FTP codes in logging output") 108 | (socket)) 109 | (:documentation "Represents an FTP connection and associated state. The INITIALIZE-INSTANCE :AFTER method takes care of connection and login, if possible.")) 110 | 111 | (defmacro %doc-fns (&rest list) 112 | `(progn ,@(loop :for (sym doc) :on list :by #'cddr 113 | :collect `(setf (documentation ',sym 'function) ',doc)))) 114 | (%doc-fns ftp-hostname "The remote hostname" 115 | ftp-port "The remote port" 116 | ftp-username "The login username" 117 | ftp-password "The login password" 118 | ftp-session-stream "The session stream for the FTP connection" 119 | passive-ftp-p "Non-nil iff given FTP connection is to use passive FTP for data transfers" 120 | (setf passive-ftp-p) "Value should be non-nil to use passive FTP for data transfers with the given FTP connection" 121 | code-cut-off-p "Non-nil iff FTP codes are to be cut-off when logging" 122 | (setf code-cut-off-p) "Alter value of code-cut-off-p") 123 | 124 | (defmacro with-ftp-connection-slots ((conn) &body body) 125 | `(with-slots (socket hostname port username password session-stream passive-ftp-p code-cut-off-p) ,conn 126 | ,@body)) 127 | 128 | (defmethod print-object ((obj ftp-connection) stream) 129 | (with-ftp-connection-slots (obj) 130 | (print-unreadable-object (obj stream) 131 | (format stream "FTP connection to ~A:~A username: ~A" 132 | hostname port username)))) 133 | 134 | (defun raise-ftp-error (error-code error-msg &key (expected-code nil)) 135 | (cond ((and (>= error-code 400) 136 | (< error-code 500)) 137 | (error 'transient-negative-completion 138 | :ftp-error-code error-code 139 | :error-message error-msg)) 140 | ((and (>= error-code 500) 141 | (< error-code 600)) 142 | (error 'permanent-negative-completion 143 | :ftp-error-code error-code 144 | :error-message error-msg)) 145 | (expected-code 146 | (error 'invalid-code 147 | :expected expected-code 148 | :received error-code 149 | :ftp-error-code error-code 150 | :error-message error-msg)) 151 | (t 152 | (error 'ftp-error 153 | :ftp-error-code error-code 154 | :error-message error-msg)))) 155 | 156 | (defun data-to-string (data) 157 | "Converts a list of strings, such as that produced by receive-response, to one string with newlines after each formerly-list-element." 158 | (format nil "~{~A~%~}" data)) 159 | 160 | (defgeneric expect-code-or-lose (conn expected-code)) 161 | 162 | (defmethod expect-code-or-lose ((conn ftp-connection) (expected-code integer)) 163 | (multiple-value-bind (data code) 164 | (receive-response conn :block t) 165 | (unless (eql code expected-code) 166 | (raise-ftp-error code (data-to-string data) 167 | :expected-code expected-code)) 168 | data)) 169 | 170 | (defmethod initialize-instance :after ((conn ftp-connection) &rest initargs) 171 | (declare (ignorable initargs)) 172 | (connect-to-server conn)) 173 | 174 | (defgeneric connect-to-server (conn) 175 | (:documentation "Attempts to connect to the server using the information provided by connection-variable. If connection-variable represents an existing connection, then that connection will be closed and a new one established.")) 176 | 177 | (defmethod connect-to-server ((conn ftp-connection)) 178 | (with-ftp-connection-slots (conn) 179 | (unless (and hostname port (integerp port) (stringp hostname)) 180 | (error "You must specify a hostname string and an integer port")) 181 | (when (and (slot-boundp conn 'socket) (streamp (socket-stream socket))) 182 | (close (socket-stream socket))) 183 | (setf socket (socket-connect hostname port)) 184 | (unless socket 185 | (error "Error connecting to ~A:~A" hostname port)) 186 | (when (and username (stringp username)) 187 | (expect-code-or-lose conn 220) 188 | (send-raw-line conn (format nil "USER ~A" username)) 189 | (if (and password (stringp password)) 190 | (multiple-value-bind (data code) (receive-response conn :block t) 191 | (case code 192 | (331 193 | (send-raw-line conn (format nil "PASS ~A" password)) 194 | (expect-code-or-lose conn 230)) 195 | (230) 196 | (otherwise (raise-ftp-error code (data-to-string data))))) 197 | (expect-code-or-lose conn 230))) 198 | (values))) 199 | 200 | ;; FIXME: Does this in any way interfere with FTP's Unix/DOS line-ending conversion? 201 | #+clisp 202 | (defmethod connect-to-server :around ((conn ftp-connection)) 203 | "clisp considers #\Linefeed and #\Newline to be identical, including conversion 204 | to CRLF for :DOS line-endings. This is a hack to let us say #\Return #\Linefeed 205 | without ending up with a CR/CR/LF sequence." 206 | ;; custom:*default-file-encoding* is a symbol-macro and thus can not be bound 207 | ;; by let, hence the use of clisp's letf, which binds places. 208 | (ext:letf ((custom:*default-file-encoding* 209 | (ext:make-encoding :charset (ext:encoding-charset custom:*default-file-encoding*) 210 | :line-terminator :unix))) 211 | (call-next-method))) 212 | 213 | (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) 214 | "Opens and ensures proper close of an FTP connection. Binds connection-variable to the FTP-CONNECTION object in the scope of body. Arguments are similar to that of the initargs for the class FTP-CONNECTION." 215 | `(let ((,conn (make-instance 'ftp-connection 216 | ,@(if hostname `(:hostname ,hostname) ()) 217 | ,@(if port `(:port ,port) ()) 218 | ,@(if username `(:username ,username) ()) 219 | ,@(if password `(:password ,password) ()) 220 | ,@(if passive-ftp-p 221 | `(:passive-ftp-p ,passive-ftp-p) ()) 222 | ,@(if session-stream 223 | `(:session-stream ,session-stream) ()) 224 | ,@(if code-cut-off-p-p 225 | `(:code-cut-off-p ,code-cut-off-p) ())))) 226 | (if (null ,conn) 227 | (if (eql ,if-failed :error) 228 | (error "Connection to ~A:~A failed" ,hostname ,port) 229 | ,if-failed) 230 | (unwind-protect (progn ,@body) 231 | (close-connection ,conn))))) 232 | 233 | (defgeneric log-session (conn data)) 234 | 235 | (defmethod log-session ((conn ftp-connection) (data string)) 236 | (with-ftp-connection-slots (conn) 237 | (when (and session-stream (streamp session-stream)) 238 | (write-string data session-stream)) 239 | (values))) 240 | 241 | (defmethod log-session ((conn ftp-connection) (data list)) 242 | (log-session conn (data-to-string data))) 243 | 244 | (defgeneric close-connection (conn) 245 | (:documentation "Closes the given FTP connection")) 246 | 247 | (defmethod close-connection ((conn ftp-connection)) 248 | (with-ftp-connection-slots (conn) 249 | (close (socket-stream socket)))) 250 | 251 | (defgeneric send-raw-line (conn line)) 252 | 253 | (defmethod send-raw-line ((conn ftp-connection) (line string)) 254 | (with-ftp-connection-slots (conn) 255 | (let ((line (format nil "~A~C~C" line #\Return #\Linefeed))) 256 | (log-session conn line) 257 | (write-string line (socket-stream socket))) 258 | (force-output (socket-stream socket)) 259 | (values))) 260 | 261 | (defgeneric data-ready-p (conn) 262 | (:documentation "Non-nil iff data is waiting to be read from the control connection.")) 263 | 264 | (defmethod data-ready-p ((conn ftp-connection)) 265 | (with-ftp-connection-slots (conn) 266 | (listen (socket-stream socket)))) 267 | 268 | (defun clean-ftp-response (data) 269 | (mapcar #'(lambda (line) 270 | (string-trim '(#\Return #\Linefeed #\Newline) 271 | line)) 272 | data)) 273 | 274 | (defun maybe-cut-off-code (cut-off-p data code) 275 | (if cut-off-p 276 | data 277 | (mapcar #'(lambda (x) 278 | (if (and (> (length x) 3) 279 | (eql (parse-integer x :end 3 :junk-allowed t) 280 | code)) 281 | (subseq x 4) 282 | x)) 283 | data))) 284 | 285 | (defgeneric receive-response (conn &key block) 286 | (:documentation "Receives a response from the FTP server. Returns a list of strings as the first value and the response code as the second. If :BLOCK is T, then will block until response received. Otherwise return NIL if nothing is available currently.")) 287 | 288 | (defmethod receive-response ((conn ftp-connection) &key (block nil)) 289 | (with-ftp-connection-slots (conn) 290 | (when (and (not block) (not (data-ready-p conn))) 291 | (return-from receive-response nil)) 292 | (loop :with initial-line = (read-line (socket-stream socket)) 293 | :with ftp-code = (parse-integer initial-line :end 3) 294 | :for line = initial-line :then (read-line (socket-stream socket)) 295 | :for line-code = ftp-code :then 296 | (when (> (length line) 3) 297 | (parse-integer line :end 3 298 | :junk-allowed t)) 299 | :when (and code-cut-off-p (eql line-code ftp-code)) 300 | :collect (subseq line 4) :into lines 301 | :else 302 | :collect line :into lines 303 | :end 304 | :until (and (eql line-code ftp-code) 305 | (char= (char line 3) #\Space)) 306 | :finally (let ((data (clean-ftp-response lines))) 307 | (log-session conn data) 308 | (return (values (maybe-cut-off-code code-cut-off-p 309 | data 310 | ftp-code) 311 | ftp-code)))))) 312 | 313 | (defgeneric send-port-command (conn ip port-num)) 314 | 315 | (defmethod send-port-command ((conn ftp-connection) (ip string) (port-num integer)) 316 | (multiple-value-bind (quot rem) 317 | (truncate port-num 256) 318 | (send-raw-line conn 319 | (format nil "PORT ~A,~A,~A" 320 | (substitute #\, #\. ip) quot rem)))) 321 | 322 | (defgeneric receive-pasv-response (conn)) 323 | 324 | (defmethod receive-pasv-response ((conn ftp-connection)) 325 | (with-ftp-connection-slots (conn) 326 | (multiple-value-bind (data code) 327 | (receive-response conn :block t) 328 | (unless (eql code 227) 329 | (raise-ftp-error code (data-to-string data) 330 | :expected-code 227)) 331 | (let ((start (position #\( (first data) :from-end t)) 332 | (end (position #\) (first data) :from-end t))) 333 | (unless (and start end) 334 | (error "Unable to parse PASV response")) 335 | (let ((numbers (split-sequence #\, (first data) 336 | :start (1+ start) 337 | :end end))) 338 | (values (format nil "~{~A~^.~}" 339 | (subseq numbers 0 4)) 340 | (+ (ash (parse-integer (fifth numbers)) 8) 341 | (parse-integer (sixth numbers))))))))) 342 | 343 | (defgeneric setup-port (conn &key element-type)) 344 | 345 | (defmethod setup-port ((conn ftp-connection) &key (element-type '(unsigned-byte 8))) 346 | (with-ftp-connection-slots (conn) 347 | (let ((server-socket 348 | (socket-listen *wildcard-host* *auto-port* :element-type element-type)) 349 | (local-ip (vector-quad-to-dotted-quad (get-local-name socket)))) 350 | (send-port-command conn local-ip (get-local-port server-socket)) 351 | server-socket))) 352 | 353 | (defgeneric establish-data-transfer (conn command &key rest type)) 354 | 355 | (defmethod establish-data-transfer ((conn ftp-connection) (command string) &key (rest nil) (type :binary)) 356 | (with-ftp-connection-slots (conn) 357 | (send-raw-line conn (format nil "TYPE ~A" 358 | (ecase type 359 | ((:binary :image) "I") 360 | (:ascii "A")))) 361 | (expect-code-or-lose conn 200) 362 | (cond (passive-ftp-p 363 | (send-raw-line conn "PASV") 364 | (multiple-value-bind (dtp-hostname dtp-port) 365 | (receive-pasv-response conn) 366 | (let ((data-socket 367 | (socket-connect dtp-hostname dtp-port 368 | :element-type (ecase type 369 | ((:binary :image) '(unsigned-byte 8)) 370 | (:ascii 'character))))) 371 | (when (and rest (integerp rest)) 372 | (send-raw-line conn (format nil "REST ~A" rest))) 373 | (send-raw-line conn command) 374 | data-socket))) 375 | (t 376 | (let ((server-socket (setup-port conn :element-type (ecase type 377 | ((:binary :image) 378 | '(unsigned-byte 8)) 379 | (:ascii 'character))))) 380 | (unwind-protect 381 | (progn 382 | (when (and rest (integerp rest)) 383 | (send-raw-line conn (format nil "REST ~A" rest))) 384 | (expect-code-or-lose conn 200) 385 | (send-raw-line conn command) 386 | (socket-accept server-socket)) 387 | (socket-close server-socket))))))) 388 | 389 | (defgeneric flush-response (conn)) 390 | 391 | (defmethod flush-response ((conn ftp-connection)) 392 | (loop while (receive-response conn))) 393 | 394 | (defgeneric call-with-transfer-socket (conn command fn &rest args) 395 | (:documentation "Similar to WITH-TRANSFER-SOCKET, except that function is a function which accepts a single argument; namely the transfer-socket")) 396 | 397 | (defmethod call-with-transfer-socket ((conn ftp-connection) (command string) (fn function) &rest args) 398 | (flush-response conn) 399 | (let ((transfer-socket (apply #'establish-data-transfer 400 | conn command args))) 401 | (unwind-protect 402 | (funcall fn transfer-socket) 403 | (progn 404 | (close (socket-stream transfer-socket)) 405 | (loop 406 | (multiple-value-bind (data code) 407 | (receive-response conn) 408 | (declare (ignorable data)) 409 | (when (and (integerp code) (eql code 226)) 410 | (return-from call-with-transfer-socket t)) 411 | (when (and (integerp code) (>= code 500)) 412 | (return-from call-with-transfer-socket nil)))))))) 413 | 414 | (defmacro with-transfer-socket ((socket conn command &rest args) &body body) 415 | "Opens a data transfer socket in the scope of body, using the given FTP connection and executing the given FTP command-string. If :REST is specified, then the FTP \"REST\" command will be sent with the value of the argument. :TYPE may be :BINARY or :ASCII. Closes the transfer-socket upon dynamic exit of body." 416 | `(call-with-transfer-socket ,conn ,command 417 | #'(lambda (,socket) ,@body) 418 | ,@args)) 419 | 420 | (defgeneric send-list-command (conn output &optional pathname) 421 | (:documentation "Sends the FTP LIST command. If OUTPUT is NIL, returns a string. If OUTPUT is T, prints to *standard-output*. Otherwise, it treats OUTPUT as the output stream.")) 422 | 423 | (defmethod send-list-command ((conn ftp-connection) (output null) &optional (pathname ".")) 424 | (with-output-to-string (s) 425 | (send-list-command conn s pathname))) 426 | 427 | ;; FIXME: Should (output t) be (output (eq t))? Running when output is 428 | ;; something like "ham" would be ... weird. 429 | (defmethod send-list-command ((conn ftp-connection) (output t) &optional (pathname ".")) 430 | (send-list-command conn *standard-output* pathname)) 431 | 432 | (defmethod send-list-command ((conn ftp-connection) (output stream) &optional (pathname ".")) 433 | (flet ((read-all (s) 434 | (loop (handler-case (write-line (read-line (socket-stream s)) output) 435 | (end-of-file () (return (values))))))) 436 | (with-transfer-socket (s conn (format nil "LIST ~A" pathname) 437 | :type :ascii) 438 | (read-all s)))) 439 | 440 | (defgeneric send-nlst-command (conn output &optional pathname) 441 | (:documentation "Sends the FTP NLST command. If OUTPUT is NIL, returns a string. If OUTPUT is T, prints to *standard-output*. Otherwise, it treats OUTPUT as the output stream.")) 442 | 443 | (defmethod send-nlst-command ((conn ftp-connection) (output null) &optional (pathname ".")) 444 | (with-output-to-string (s) 445 | (send-nlst-command conn s pathname))) 446 | 447 | ;; FIXME: Should (output t) be (output (eq t))? Running when output is 448 | ;; something like "ham" would be ... weird. 449 | (defmethod send-nlst-command ((conn ftp-connection) (output t) &optional (pathname ".")) 450 | (send-nlst-command conn *standard-output* pathname)) 451 | 452 | (defmethod send-nlst-command ((conn ftp-connection) (output stream) &optional (pathname ".")) 453 | (flet ((read-all (s) 454 | (loop (handler-case (write-line (read-line (socket-stream s)) output) 455 | (end-of-file () (return (values))))))) 456 | (with-transfer-socket (s conn (format nil "NLST ~A" pathname) 457 | :type :ascii) 458 | (read-all s)))) 459 | 460 | (defgeneric retrieve-filename-list (conn &optional pathname) 461 | (:documentation "Retrieves a list of filenames for the given pathname.")) 462 | 463 | (defmethod retrieve-filename-list ((conn ftp-connection) &optional (pathname ".")) 464 | (let* ((data (send-nlst-command conn nil pathname)) 465 | (split-data (split-sequence #\Newline data 466 | :remove-empty-subseqs t))) 467 | (mapcar #'(lambda (x) (string-trim '(#\Return) x)) split-data))) 468 | 469 | (defgeneric retrieve-file-info-list (conn &optional pathname) 470 | (:documentation "Retrieves a list of the form (type name) where type is :DIRECTORY or :FILE and name is a filename in the given directory named by pathname. Note: this is implemented by attempting CWDs, and may break if the FTP server does strange things.")) 471 | 472 | (defmethod retrieve-file-info-list ((conn ftp-connection) &optional (pathname ".")) 473 | (let ((names (retrieve-filename-list conn pathname)) 474 | (file-info-list nil) 475 | (orig-dir (send-pwd-command conn)) 476 | (base-dir nil)) 477 | (send-cwd-command conn pathname) 478 | (setf base-dir (send-pwd-command conn)) 479 | (unwind-protect 480 | (dolist (name names file-info-list) 481 | (handler-case 482 | (progn 483 | (send-cwd-command conn name) 484 | (push (list :directory name) file-info-list)) 485 | (ftp-error () 486 | (push (list :file name) file-info-list))) 487 | (send-cwd-command conn base-dir)) 488 | (send-cwd-command conn orig-dir)))) 489 | 490 | (defgeneric retrieve-file (conn remote-filename local-file &key type rest &allow-other-keys) 491 | (:documentation "Retrieves a file given a remote filename, and a local filename or stream. :TYPE is either :ASCII or :BINARY, and :REST specifies an integer amount to seek into the file before retrieving it.")) 492 | 493 | (defmethod retrieve-file ((conn ftp-connection) (remote-filename string) local-filename 494 | &key (type :binary) (rest nil) (if-exists :error)) 495 | (with-open-file (local-stream local-filename 496 | :direction :output 497 | :if-exists if-exists 498 | :element-type (ecase type 499 | ((:binary :image) 500 | '(unsigned-byte 8)) 501 | (:ascii 502 | 'character))) 503 | ;; if-exists can be nil, so we have to check if local-stream is non-nil 504 | (when local-stream 505 | (retrieve-file conn remote-filename local-stream :type type :rest rest)))) 506 | 507 | (defmethod retrieve-file ((conn ftp-connection) (remote-filename string) (local-stream stream) &key (type :binary) (rest nil)) 508 | (with-transfer-socket (s conn (format nil "RETR ~A" remote-filename) 509 | :type type :rest rest) 510 | (handler-case 511 | (ecase type 512 | ((:binary :image) 513 | (loop (write-byte (read-byte (socket-stream s)) local-stream))) 514 | (:ascii 515 | (loop (write-char (read-char (socket-stream s)) local-stream)))) 516 | (end-of-file () (values))))) 517 | 518 | (defgeneric store-file (conn local-filename remote-filename &key type rest) 519 | (:documentation "Stores a file given a local filename or stream and a remote filename. :TYPE is either :ASCII or :BINARY.")) 520 | 521 | (defmethod store-file ((conn ftp-connection) local-filename (remote-filename string) &key (type :binary) (rest nil)) 522 | (with-open-file (local-stream local-filename 523 | :direction :input 524 | :element-type (ecase type 525 | ((:binary :image) 526 | '(unsigned-byte 8)) 527 | (:ascii 528 | 'character))) 529 | (store-file conn local-stream remote-filename :type type :rest rest))) 530 | 531 | (defmethod store-file ((conn ftp-connection) (local-stream stream) (remote-filename string) &key (type :binary) (rest nil)) 532 | (with-transfer-socket (s conn (format nil "STOR ~A" remote-filename) 533 | :type type :rest rest) 534 | (handler-case 535 | (ecase type 536 | ((:binary :image) 537 | (loop (write-byte (read-byte local-stream) (socket-stream s)))) 538 | (:ascii 539 | (loop (write-char (read-char local-stream) (socket-stream s))))) 540 | (end-of-file () (values))))) 541 | 542 | (eval-when (:compile-toplevel :load-toplevel :execute) 543 | (defun %parse-body (body) 544 | (if (stringp (first body)) 545 | (values (first body) (rest body)) 546 | (values nil body))) 547 | (defun %get-arg-name (arg) 548 | (if (symbolp arg) 549 | arg 550 | (first arg)))) 551 | 552 | (defmacro def-simple-command (cmd (conn &rest args) &body body) 553 | (let ((name (intern (format nil "SEND-~A-COMMAND" cmd)))) 554 | (multiple-value-bind (doc body) (%parse-body body) 555 | `(progn 556 | (defgeneric ,name (,conn ,@(mapcar #'%get-arg-name args)) 557 | ,@(if doc `((:documentation ,doc)))) 558 | (defmethod ,name ((,conn ftp-connection) ,@args) 559 | (flush-response ,conn) 560 | ,@body) 561 | (export ',name) 562 | ',name)))) 563 | 564 | (def-simple-command dele (conn (remote-filename string)) 565 | (send-raw-line conn (format nil "DELE ~A" remote-filename)) 566 | (expect-code-or-lose conn 250)) 567 | 568 | (def-simple-command size (conn (remote-filename string)) 569 | "Sends the FTP SIZE command on the given remote-filename. Returns an integer size. Signals error if no such file." 570 | (send-raw-line conn (format nil "SIZE ~A" remote-filename)) 571 | (parse-integer (first (expect-code-or-lose conn 213)))) 572 | 573 | (def-simple-command cwd (conn (remote-dir string)) 574 | "Sends the FTP CWD command, to change to the given remote-directory. If remote-directory is \"..\", CDUP is sent instead. Signals error if not possible." 575 | (send-raw-line conn (if (string-equal remote-dir "..") 576 | "CDUP" 577 | (format nil "CWD ~A" remote-dir))) 578 | (expect-code-or-lose conn 250)) 579 | 580 | (def-simple-command cdup (conn) 581 | "Sends the FTP CDUP command." 582 | (send-raw-line conn "CDUP") 583 | (expect-code-or-lose conn 250)) 584 | 585 | (defun parse-257-response (string) 586 | (let ((start (1+ (position #\" string))) 587 | (last (1- (length string)))) 588 | (with-output-to-string (out) 589 | (do ((i start (1+ i))) 590 | ((>= i last) (values)) 591 | (if (char= (char string i) #\") 592 | (cond ((char= (char string (1+ i)) #\") 593 | (write-char #\" out) 594 | (incf i)) 595 | (t (return (values)))) 596 | (write-char (char string i) out)))))) 597 | 598 | (def-simple-command pwd (conn) 599 | "Sends the FTP PWD command and returns the current working directory as a string." 600 | (send-raw-line conn "PWD") 601 | (parse-257-response 602 | (data-to-string (expect-code-or-lose conn 257)))) 603 | 604 | (def-simple-command mkd (conn (dir-name string)) 605 | "Sends the FTP MKD command to make a remote directory. Returns directory name as string. Signals error if not possible." 606 | (send-raw-line conn (format nil "MKD ~A" dir-name)) 607 | (parse-257-response 608 | (data-to-string (expect-code-or-lose conn 257)))) 609 | -------------------------------------------------------------------------------- /simple-client.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp -*- 2 | ;;;; Author: Matthew Danish 3 | ;;;; See LICENSE file for copyright details. 4 | ;;;; Simple FTP client using CL-FTP 5 | 6 | (defpackage #:org.mapcar.ftp.simple-client 7 | (:use #:common-lisp 8 | #:org.mapcar.ftp.client) 9 | (:nicknames #:simple-client) 10 | (:export #:connect)) 11 | 12 | (in-package #:org.mapcar.ftp.simple-client) 13 | 14 | (defparameter *command-table* 15 | '(("quit" ftp-quit "Quit the client") 16 | ("ls" ftp-list "List files (-l option for long form)") 17 | ("dir" ftp-long-list "List files, long form") 18 | ("cd" ftp-cd "Change current directory: cd [dir]") 19 | ("get" ftp-get "Get file: get remote-file [local-name]") 20 | ("put" ftp-put "Put file: put local-file [remote-name]") 21 | ("pwd" ftp-pwd "Print working directory") 22 | ("help" ftp-help "Help!"))) 23 | 24 | (defun ftp-help (conn args) 25 | (declare (ignorable conn args)) 26 | (dolist (c *command-table*) 27 | (format t "~&~A: ~A~%" (first c) (third c)))) 28 | 29 | (defun ftp-pwd (conn args) 30 | (declare (ignorable args)) 31 | (write-line (send-pwd-command conn))) 32 | 33 | (defun ftp-get (conn args) 34 | (let ((remote (first args)) 35 | (local (or (second args) (first args)))) 36 | (if (retrieve-file conn remote local) 37 | (write-line "File transferred") 38 | (write-line "Something went wrong")))) 39 | 40 | (defun ftp-put (conn args) 41 | (let ((remote (or (second args) (first args))) 42 | (local (first args))) 43 | (if (store-file conn local remote) 44 | (write-line "File transferred") 45 | (write-line "Something went wrong")))) 46 | 47 | (defun ftp-cd (conn args) 48 | (write-line 49 | (data-to-string 50 | (send-cwd-command conn 51 | (if (and args (stringp (first args))) 52 | (first args) 53 | "/"))))) 54 | 55 | (defun ftp-list (conn args) 56 | (when (find "-l" args :test #'string-equal) 57 | (ftp-long-list conn args)) 58 | (send-nlst-command conn t)) 59 | 60 | (defun ftp-long-list (conn args) 61 | (declare (ignorable args)) 62 | (send-list-command conn t)) 63 | 64 | (defun ftp-quit (conn args) 65 | (declare (ignorable conn args)) 66 | (throw 'ftp-quit t)) 67 | 68 | (defun process-line (command) 69 | ;; Kinda ugly, but easy 70 | (let ((*read-eval* nil) 71 | (*readtable* (copy-readtable)) 72 | (parts nil) 73 | (stream (make-string-input-stream command))) 74 | (setf (readtable-case *readtable*) :preserve) 75 | (handler-case 76 | (loop (push (string (read stream)) parts)) 77 | (end-of-file () nil)) 78 | (nreverse parts))) 79 | 80 | (defun ftp-shell (conn) 81 | (loop 82 | (format t "~&CL-FTP > ") 83 | (let* ((command (read-line)) 84 | (scommand (process-line command)) 85 | (fn (second (assoc (first scommand) *command-table* 86 | :test #'string-equal)))) 87 | (if fn 88 | (handler-case (funcall fn conn (rest scommand)) 89 | (ftp-error (c) 90 | (format t "~&~A: ~A~%" 91 | (ftp-error-code c) 92 | (error-message c)))) 93 | (format t "~&Unknown command!~%"))))) 94 | 95 | (defun connect (hostname &key (port 21) (username "anonymous") (password "cl-ftp@cclan.net")) 96 | (catch 'ftp-quit 97 | (with-ftp-connection (conn :hostname hostname 98 | :port port 99 | :username username 100 | :password password) 101 | (ftp-shell conn)))) 102 | 103 | --------------------------------------------------------------------------------