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

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

                   (string-append

                    (regexp-replace

                     #rx"~"

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

                     "~~")

                    "~a"))]

         [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
downloaded.

    ;; 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
rcv-ch)])

    ;;                                         (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)

        (thread

         (lambda ()

           (hook rcv-ch ctrl-ch)))


        (thread

         (lambda ()

           (letrec ([recur

                     (lambda ()

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

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

                         (recur)))])

             (recur)))))


      (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)

                                       (recur))))])

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