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