[racket] add progress monitor to ftp-download-file

From: 晓陈 (chenxiao770117 at gmail.com)
Date: Thu Oct 25 05:09:40 EDT 2012

I want to use ftp-download-file to download something, but I want to show
the progress in my gui app.

So I change net/ftp.rkt a little, let ftp-download-file can report current
progress, ftp-download-file now changed to:

(define (ftp-download-file tcp-ports folder filename [hook #f])

  ;; Save the file under the name tmp.file, rename it once download is

  ;; complete this assures we don't over write any existing file without

  ;; having a good file down

  (let* ([tmpfile (make-temporary-file




                     (path->string (build-path folder "ftptmp"))



         [new-file (open-output-file tmpfile #:exists 'replace)]

         [tcp-data (establish-data-connection tcp-ports)])

    (fprintf (ftp-connection-out tcp-ports) "RETR ~a\r\n" filename)

    (ftp-check-response (ftp-connection-in tcp-ports)

                        (ftp-connection-out tcp-ports)

                        (list #"125" #"150") print-msg (void))

    ;; hook is a lambda (-> channel? channel? any?)

    ;; (hook receive-channel control-channel)

    ;; in this lambda, can use (channel-get rcv-ch) to get bytes has

    ;; after (channel-get rcv-ch), use (channel-put ctrl-ch 0) to launch
sender to get a new size info the rcv-ch channel.

    ;; Two channels used here is want to control the "refresh speed". It
prevent receiver get size too frequently.

    ;; It means only if hook (channel-put ctrl-ch 0), then the sender will
get the downloading file size.

    ;; Example:

    ;; (ftp-download-file ftp-conn "." "testfile"

    ;;                                 (lambda (rcv-ch ctrl-ch)

    ;;                                   (letrec ([recur

    ;;                                     (lambda ()

    ;;                                       (let ([data (channel-get

    ;;                                         (when (not (= data -1))

    ;;                                           (channel-put ctrl-ch 0)

    ;;                                             (printf "~a~%" data)

    ;;                                             (sleep 1) //not too fast

    ;;                                             (recur))))])

    ;;                                     (recur))))

    (let ([rcv-ch (make-channel)]

          [ctrl-ch (make-channel)])

      (when (procedure? hook)


         (lambda ()

           (hook rcv-ch ctrl-ch)))


         (lambda ()

           (letrec ([recur

                     (lambda ()

                       (channel-put rcv-ch (file-size tmpfile))

                       (when (= 0 (channel-get ctrl-ch))



      (copy-port tcp-data new-file)

      (when (procedure? hook)

        ; send -1 to stop receiver thread

        (channel-put rcv-ch (file-size tmpfile))

        (channel-get ctrl-ch)

        (channel-put rcv-ch -1)

        ; send -1 to stop sender thread

        (channel-get rcv-ch)

        (channel-put ctrl-ch -1)))

    (close-output-port new-file)

    (close-input-port tcp-data)

    (ftp-check-response (ftp-connection-in tcp-ports)

                        (ftp-connection-out tcp-ports)

                        #"226" print-msg (void))

    (rename-file-or-directory tmpfile (build-path folder filename) #t)))

A little complicated? But is worked.

You must send control-channel 0 to let sender to refresh current tmp file
size and reget file size.

This prevent sender refresh file size too frequently.

Below is the example:

  (ftp-download-file ftp-conn "." "testfile"

                     (lambda (rcv-ch snd-ch)

                       (letrec ([recur

                                 (lambda ()

                                   (let ([data (channel-get rcv-ch)])

                                     (when (not (= data -1))

                                       (channel-put snd-ch 0)

                                       (printf "~a~%" (inexact->exact
(round (* 100 (/ data total-size)))))

                                       (sleep 1)


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.racket-lang.org/users/archive/attachments/20121025/3cf94e43/attachment.html>

Posted on the users mailing list.