<p style="margin:0px;font-family:Times;font-size:medium">I want to use ftp-download-file to download something, but I want to show the progress in my gui app.</p><p style="margin:0px;font-family:Times;font-size:medium">So I change net/ftp.rkt a little, let ftp-download-file can report current progress, ftp-download-file now changed to:</p>
<p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">(define (ftp-download-file tcp-ports folder filename [hook #f])</p>
<p style="margin:0px;font-family:Times;font-size:medium">� ;; Save the file under the name tmp.file, rename it once download is</p><p style="margin:0px;font-family:Times;font-size:medium">� ;; complete this assures we don&#39;t over write any existing file without</p>
<p style="margin:0px;font-family:Times;font-size:medium">� ;; having a good file down</p><p style="margin:0px;font-family:Times;font-size:medium">� (let* ([tmpfile (make-temporary-file</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � � � � � � �(string-append</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � (regexp-replace</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � �#rx&quot;~&quot;</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � �(path-&gt;string (build-path folder &quot;ftptmp&quot;))</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � �&quot;~~&quot;)</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � &quot;~a&quot;))]</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � �[new-file (open-output-file tmpfile #:exists &#39;replace)]</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � �[tcp-data (establish-data-connection tcp-ports)])</p><p style="margin:0px;font-family:Times;font-size:medium">� � (fprintf (ftp-connection-out tcp-ports) &quot;RETR ~a\r\n&quot; filename)</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � (ftp-check-response (ftp-connection-in tcp-ports)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � (ftp-connection-out tcp-ports)</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � (list #&quot;125&quot; #&quot;150&quot;) print-msg (void))</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; hook is a lambda (-&gt; channel? channel? any?)</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; (hook receive-channel control-channel)</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; in this lambda, can use (channel-get rcv-ch) to get bytes has downloaded.</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; after (channel-get rcv-ch), use (channel-put ctrl-ch 0) to launch sender to get a new size info the rcv-ch channel.</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � ;; Two channels used here is want to control the &quot;refresh speed&quot;. It prevent receiver get size too frequently.</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; It means only if hook (channel-put ctrl-ch 0), then the sender will get the downloading file size.</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; Example:</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; (ftp-download-file ftp-conn &quot;.&quot; &quot;testfile&quot;</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; � � � � � � � � � � � � � � � � (lambda (rcv-ch ctrl-ch)</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; � � � � � � � � � � � � � � � � � (letrec ([recur</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; � � � � � � � � � � � � � � � � � � (lambda ()</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; � � � � � � � � � � � � � � � � � � � (let ([data (channel-get rcv-ch)])</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; � � � � � � � � � � � � � � � � � � � � (when (not (= data -1))</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; � � � � � � � � � � � � � � � � � � � � � (channel-put ctrl-ch 0)</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; � � � � � � � � � � � � � � � � � � � � � � (printf &quot;~a~%&quot; data)</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; � � � � � � � � � � � � � � � � � � � � � � (sleep 1) //not too fast</p><p style="margin:0px;font-family:Times;font-size:medium">� � ;; � � � � � � � � � � � � � � � � � � � � � � (recur))))])</p><p style="margin:0px;font-family:Times;font-size:medium">
� � ;; � � � � � � � � � � � � � � � � � � (recur))))</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">� � (let ([rcv-ch (make-channel)]</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � � [ctrl-ch (make-channel)])</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">� � � (when (procedure? hook)</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � (thread</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � �(lambda ()</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � �(hook rcv-ch ctrl-ch)))</p><p style="margin:0px;font-family:Times;font-size:medium">
<br></p><p style="margin:0px;font-family:Times;font-size:medium">� � � � (thread</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � �(lambda ()</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � � �(letrec ([recur</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � �(lambda ()</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � �(channel-put rcv-ch (file-size tmpfile))</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � �(when (= 0 (channel-get ctrl-ch))</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � �(recur)))])</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � � � �(recur)))))</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">� � � (copy-port tcp-data new-file)</p><p style="margin:0px;font-family:Times;font-size:medium">
<br></p><p style="margin:0px;font-family:Times;font-size:medium">� � � (when (procedure? hook)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � ; send -1 to stop receiver thread</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � (channel-put rcv-ch (file-size tmpfile))</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � (channel-get ctrl-ch)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � (channel-put rcv-ch -1)</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � �</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � ; send -1 to stop sender thread</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � (channel-get rcv-ch)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � (channel-put ctrl-ch -1)))</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">
<br></p><p style="margin:0px;font-family:Times;font-size:medium">� � (close-output-port new-file)</p><p style="margin:0px;font-family:Times;font-size:medium">� � (close-input-port tcp-data)</p><p style="margin:0px;font-family:Times;font-size:medium">
� � (ftp-check-response (ftp-connection-in tcp-ports)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � (ftp-connection-out tcp-ports)</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � � � � � � � � � #&quot;226&quot; print-msg (void))</p><p style="margin:0px;font-family:Times;font-size:medium">� � (rename-file-or-directory tmpfile (build-path folder filename) #t)))</p><p style="margin:0px;font-family:Times;font-size:medium">
<br></p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">A little complicated? But is worked.</p><p style="margin:0px;font-family:Times;font-size:medium">
<br></p><p style="margin:0px;font-family:Times;font-size:medium">You must send control-channel 0 to let sender to refresh current tmp file size and reget file size.</p><p style="margin:0px;font-family:Times;font-size:medium">
This prevent�sender refresh file size too frequently.</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">Below is the example:</p><p style="margin:0px;font-family:Times;font-size:medium">
<br></p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><p style="margin:0px;font-family:Times;font-size:medium">� (ftp-download-file ftp-conn &quot;.&quot; &quot;testfile&quot;</p><p style="margin:0px;font-family:Times;font-size:medium">
� � � � � � � � � � �(lambda (rcv-ch snd-ch)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � �(letrec ([recur</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � �(lambda ()</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � � �(let ([data (channel-get rcv-ch)])</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � � � �(when (not (= data -1))</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � � � � �(channel-put snd-ch 0)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � � � � �(printf &quot;~a~%&quot; (inexact-&gt;exact (round (* 100 (/ data total-size)))))</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � � � � �(sleep 1)</p><p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � � � � � � � � �(recur))))])</p>
<p style="margin:0px;font-family:Times;font-size:medium">� � � � � � � � � � � � �(recur))))</p><p style="margin:0px;font-family:Times;font-size:medium"><br></p><div style="font-family:Times;font-size:medium"></div>