diff --git a/collects/net/ftp-unit.ss b/collects/net/ftp-unit.ss index 414e2ca..4e3723b 100644 --- a/collects/net/ftp-unit.ss +++ b/collects/net/ftp-unit.ss @@ -31,7 +31,7 @@ expected)) (error 'ftp "exected result code ~a, got ~a" expected line)))) - ;; ftp-check-response : input-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any + ;; ftp-check-response : input-port output-port bytes-or-byteslist-or-#f (bytes any -> any) any -> any ;; ;; Checks a standard-format response, checking for the given ;; expected 3-digit result code if expected is not #f. @@ -44,7 +44,8 @@ ;; ;; If an unexpected result is found, an exception is raised, and the ;; stream is left in an undefined state. - (define (ftp-check-response tcpin expected diagnostic-accum accum-start) + (define (ftp-check-response tcpin tcpout expected diagnostic-accum accum-start) + (flush-output tcpout) (let ([line (read-bytes-line tcpin 'any)]) (cond [(eof-object? line) @@ -109,6 +110,7 @@ (define (establish-data-connection tcp-ports) (fprintf (tcp-connection-out tcp-ports) "PASV~n") (let ([response (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) #"227" (lambda (s ignore) s) ;; should be the only response (void))]) @@ -125,7 +127,9 @@ (list-ref reg-list 4)) (+ (* 256 pn1) pn2))]) (fprintf (tcp-connection-out tcp-ports) "TYPE I~n") - (ftp-check-response (tcp-connection-in tcp-ports) #"200" void (void)) + (ftp-check-response (tcp-connection-in tcp-ports) + (tcp-connection-out tcp-ports) + #"200" void (void)) (close-output-port tcp-data-out) tcp-data)))) @@ -135,15 +139,15 @@ (void)) (define (ftp-establish-connection* in out username password) - (ftp-check-response in #"220" print-msg (void)) + (ftp-check-response in out #"220" print-msg (void)) (display (bytes-append #"USER " (string->bytes/locale username) #"\n") out) - (let ([no-password? (ftp-check-response in (list #"331" #"230") + (let ([no-password? (ftp-check-response in out (list #"331" #"230") (lambda (line 230?) (or 230? (regexp-match #rx#"^230" line))) #f)]) (unless no-password? (display (bytes-append #"PASS " (string->bytes/locale password) #"\n") out) - (ftp-check-response in #"230" void (void)))) + (ftp-check-response in out #"230" void (void)))) (make-tcp-connection in out)) (define (ftp-establish-connection server-address server-port username password) @@ -152,7 +156,7 @@ (define (ftp-close-connection tcp-ports) (fprintf (tcp-connection-out tcp-ports) "QUIT~n") - (ftp-check-response (tcp-connection-in tcp-ports) #"221" void (void)) + (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) #"221" void (void)) (close-input-port (tcp-connection-in tcp-ports)) (close-output-port (tcp-connection-out tcp-ports))) @@ -173,17 +177,20 @@ (define (ftp-cd ftp-ports new-dir) (display (bytes-append #"CWD " (string->bytes/locale new-dir) #"\n") (tcp-connection-out ftp-ports)) - (ftp-check-response (tcp-connection-in ftp-ports) #"250" void (void))) + (ftp-check-response (tcp-connection-in ftp-ports) (tcp-connection-out ftp-ports) + #"250" void (void))) (define re:dir-line #rx#"^(.)......... .* ([A-Z].* .* [0-9][0-9]:?[0-9][0-9]) (.*)$") (define (ftp-directory-list tcp-ports) (let ([tcp-data (establish-data-connection tcp-ports)]) (fprintf (tcp-connection-out tcp-ports) "LIST~n") - (ftp-check-response (tcp-connection-in tcp-ports) #"150" void (void)) + (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) + #"150" void (void)) (let ([dir-list (filter-tcp-data tcp-data re:dir-line)]) (close-input-port tcp-data) - (ftp-check-response (tcp-connection-in tcp-ports) #"226" print-msg (void)) + (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) + #"226" print-msg (void)) (map (lambda (l) (map bytes->string/locale l)) dir-list)))) (define (ftp-download-file tcp-ports folder filename) @@ -199,11 +206,13 @@ [tcpstring (bytes-append #"RETR " (string->bytes/locale filename) #"\n")] [tcp-data (establish-data-connection tcp-ports)]) (display tcpstring (tcp-connection-out tcp-ports)) - (ftp-check-response (tcp-connection-in tcp-ports) #"150" print-msg (void)) + (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) + #"150" print-msg (void)) (copy-port tcp-data new-file) (close-output-port new-file) (close-input-port tcp-data) - (ftp-check-response (tcp-connection-in tcp-ports) #"226" print-msg (void)) + (ftp-check-response (tcp-connection-in tcp-ports) (tcp-connection-out tcp-ports) + #"226" print-msg (void)) (rename-file-or-directory tmpfile (build-path folder filename) #t))) ;; (printf "FTP Client Installed...~n") diff --git a/collects/net/imap-unit.ss b/collects/net/imap-unit.ss index ca1e6f6..27a6002 100644 --- a/collects/net/imap-unit.ss +++ b/collects/net/imap-unit.ss @@ -192,6 +192,7 @@ ;; Have to send size, then continue if the ;; server consents (fprintf w "{~a}\r\n" (bytes-length cmd)) + (flush-output w) (get-response r #f void (list (lambda (gloop data) (void)))) ;; Continue by writing the data (write-bytes cmd w)) @@ -202,6 +203,7 @@ (fprintf w " ") (loop (cdr cmd)))])) (fprintf w "\r\n") + (flush-output w) (get-response r id (wrap-info-handler imap info-handler) continuation-handler))) (define (check-ok reply) diff --git a/collects/net/smtp-unit.ss b/collects/net/smtp-unit.ss index 98ae529..980ac24 100644 --- a/collects/net/smtp-unit.ss +++ b/collects/net/smtp-unit.ss @@ -23,7 +23,8 @@ (and (>= (string-length l) (string-length n)) (string=? n (substring l 0 (string-length n))))) - (define (check-reply r v) + (define (check-reply r v w) + (flush-output w) (let ([l (read-line r (if debug-via-stdio? 'linefeed 'return-linefeed))]) @@ -36,7 +37,7 @@ (let ([n- (string-append n "-")]) (when (starts-with? l n-) ;; Multi-line reply. Go again. - (check-reply r v))))))) + (check-reply r v w))))))) (define (protect-line l) ;; If begins with a dot, add one more @@ -64,25 +65,25 @@ (close-input-port r) (close-output-port w) (raise x))]) - (check-reply r 220) + (check-reply r 220 w) (log "hello~n") (fprintf w "EHLO ~a~a" ID crlf) - (check-reply r 250) + (check-reply r 250 w) (log "from~n") (fprintf w "MAIL FROM:<~a>~a" sender crlf) - (check-reply r 250) + (check-reply r 250 w) (log "to~n") (for-each (lambda (dest) (fprintf w "RCPT TO:<~a>~a" dest crlf) - (check-reply r 250)) + (check-reply r 250 w)) recipients) (log "header~n") (fprintf w "DATA~a" crlf) - (check-reply r 354) + (check-reply r 354 w) (fprintf w "~a" header) (for-each (lambda (l) @@ -96,11 +97,11 @@ (log "dot~n") (fprintf w ".~a" crlf) (flush-output w) - (check-reply r 250) + (check-reply r 250 w) (log "quit~n") (fprintf w "QUIT~a" crlf) - (check-reply r 221) + (check-reply r 221 w) (close-output-port w) (close-input-port r))) diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index d77a715..9aec780 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -137,9 +137,8 @@ strings))))) (display "\r\n" client->server) (when post-data - (display post-data client->server) - (flush-output client->server)) ;; technically not needed for TCP ports - (tcp-abandon-port client->server) + (display post-data client->server)) + (tcp-abandon-port client->server) ; flushes server->client))) ;; file://get-pure-port : url -> in-port