diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm index f87e3ac..484cdea 100644 --- a/scheme/lib/ftp.scm +++ b/scheme/lib/ftp.scm @@ -85,15 +85,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; beware, the log file contains password information! -;;: string [ x string x port] -> connection -(define (ftp-connect host . args) + +(define (ftp-connect host login password passive? . args) (let-optionals* args ((logfile #f)) - (let* ((LOG (and logfile - (open-output-file logfile - (if (file-exists? logfile) - (bitwise-ior open/write open/append) - (bitwise-ior open/write open/create)) - #o600))) + (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")) @@ -103,32 +107,38 @@ (service-info:port srvc-info))) (connection (make-ftp-connection hostname sock - LOG "" ""))) + 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 optional login +;; 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. If not found we -;; default to login "anonymous" with password user@host. -;;: connection [ x string x password ] -> status -(define (ftp-login connection . args) - (let ((netrc-record (netrc-parse))) - (let-optionals* args - ((login - (netrc-lookup-login netrc-record - (ftp-connection-host-name connection))) - (password - (netrc-lookup-password netrc-record - (ftp-connection-host-name connection)))) - (set-ftp-connection-login! connection login) - (set-ftp-connection-password! connection password) - (ftp-send-command connection (format #f "USER ~a" login) any-code) ; "331" - (ftp-send-command connection (format #f "PASS ~a" password))))) ; "230" +;; try to determine a login and password for the server. + +(define (ftp-login connection login password) + (let* ((netrc-record (netrc-parse)) + (login (or login + (netrc-lookup-login netrc-record + (ftp-connection-host-name connection)))) + (password (or password + (netrc-lookup-password 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" password) + (exactly-code "230")))))) ;; Type must be one of 'binary or 'text or 'ascii, or a string which will be ;; sent verbatim @@ -241,7 +251,7 @@ (define (ftp-ls connection . maybe-dir) (let* ((sock (ftp-open-data-connection connection))) (ftp-send-command connection - (ftp-build-command-string "NLST" maybe-dir) + (apply ftp-build-command-string "NLST" maybe-dir) (code-with-prefix "1")) (receive (newsock newsockaddr) (accept-connection sock) @@ -255,7 +265,7 @@ (define (ftp-dir connection . maybe-dir) (let* ((sock (ftp-open-data-connection connection))) (ftp-send-command connection - (ftp-build-command-string "LIST" maybe-dir) + (apply ftp-build-command-string "LIST" maybe-dir) (code-with-prefix "1")) (receive (newsock newsockaddr) (accept-connection sock) @@ -347,13 +357,12 @@ ;; 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 logfd login password) + (make-ftp-connection host-name command-socket passive-mode? logfd) ftp-connection? (host-name ftp-connection-host-name) (command-socket ftp-connection-command-socket) - (logfd ftp-connection-logfd) - (login ftp-connection-login set-ftp-connection-login!) - (password ftp-connection-password set-ftp-connection-password!)) + (passive-mode? ftp-connection-passive-mode?) + (logfd ftp-connection-logfd)) (define-condition-type 'ftp-error '(error)) (define ftp-error? (condition-predicate 'ftp-error))