scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Revamp FTP-GET, FTP-PUT, and FTP-APPEND: always take remote file name 

as argument and an ACT procedure which acts on the data input/output
port.
This commit is contained in:
sperber 2003-01-16 10:51:40 +00:00
parent 3be94a89e4
commit d07bf7beae
1 changed files with 25 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
scheme/lib/ftp.scm
View File

@ -267,43 +267,22 @@
(define (port->lines port)
(let loop ((reverse-lines '()))
(let ((line (rread-crlf-line port)))
(let ((line (read-crlf-line port)))
(if (eof-object? line)
(reverse reverse-lines)
(loop (cons line reverse-lines))))))
;; maybe-local may be a filename to which the data should be written,
;; or #t to write data to stdout (to current-output-port to be more
;; precise), or #f to stuff the data in a string (which is returned),
;; or nothing to output to a local file with the same name as the
;; remote file.
;;: connection x string [x string | #t | #f] -> status | string
(define (ftp-get connection remote-file . maybe-local)
(let* ((sock (ftp-open-data-connection connection))
(local (if (pair? maybe-local)
(car maybe-local)
'empty))
(out (cond ((string? local) (open-output-file local))
((eq? local #t) (current-output-port))
((eq? local #f) (make-string-output-port))
(else
(open-output-file remote-file)))))
(define (ftp-get connection remote-file act)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(format #f "RETR ~a" remote-file)
(ftp-build-command-string "RETR" remote-file)
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port out
(dump (socket:inport newsock)))
(act (socket:inport newsock))
(close-socket newsock)
(close-socket sock)
(let ((status (ftp-read-reply connection)))
(if (string? local) (close out))
(if (eq? local #f)
(string-output-port-output out)
status)))))
(ftp-read-reply connection))))
;; FIXME: should have an optional argument :rename which defaults to
;; false, which would make us upload to a temporary name and rename at
@ -311,43 +290,25 @@
;; servers which are serving a load, and to avoid problems with "no
;; space on device".
;; optional argument maybe-remote-file is the name under which we wish
;; the file to appear on the remote machine. If omitted the file takes
;; the same name on the FTP server as on the local host.
;;: connection x string [ x string ] -> status
(define (ftp-put connection local-file . maybe-remote-file)
(let-optionals* maybe-remote-file ((remote-file #f))
(let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file))
(cmd (format #f "STOR ~a" (or remote-file local-file))))
(ftp-send-command connection cmd (exactly-code "150"))
(define (ftp-put connection remote-file act)
(let ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection (ftp-build-command-string "STOR" remote-file)
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port (socket:outport newsock) (dump IN))
(close (socket:outport newsock)) ; send the server EOF
(act (socket:outport newsock))
(close-socket newsock)
(let ((status (ftp-read-reply connection)))
(close IN)
(close-socket sock)
status)))))
(close-socket sock))))
;;: connection x string [x string] -> status
(define (ftp-append connection local-file . maybe-remote-file)
(let-optionals* maybe-remote-file ((remote-file #f))
(let* ((sock (ftp-open-data-connection connection))
(IN (open-input-file local-file))
(cmd (format #f "APPE ~a" (or remote-file local-file))))
(ftp-send-command connection cmd (exactly-code "150"))
(define (ftp-append connection remote-file act)
(let ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection (ftp-build-command-string "APPE" remote-file)
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
(with-current-output-port (socket:outport newsock)
(dump IN))
(close (socket:outport newsock)) ; send the server EOF
(act (socket:outport newsock))
(close-socket newsock)
(let ((status (ftp-read-reply connection)))
(close IN)
(close-socket sock)
status)))))
(close-socket sock))))
;; send a command verbatim to the remote server and wait for a
;; reply.
@ -452,9 +413,7 @@
reply))))
(define (ftp-build-command-string str . opt-args)
(if (string? opt-args)
(string-join (list str arg))
str))
(string-join (cons str opt-args)))
(define (ftp-log connection line)
(let ((LOG (ftp-connection-logfd connection)))