From 03237c06f2754ed75450defc61ad5da979adb47a Mon Sep 17 00:00:00 2001 From: Jon Zeppieri Date: Mon, 29 Aug 2011 21:26:28 -0400 Subject: [PATCH] Moved `net/ftp' code from unit to module. --- collects/net/ftp-unit.rkt | 211 +--------------------------- collects/net/ftp.rkt | 215 ++++++++++++++++++++++++++++- collects/net/scribblings/ftp.scrbl | 4 + 3 files changed, 221 insertions(+), 209 deletions(-) diff --git a/collects/net/ftp-unit.rkt b/collects/net/ftp-unit.rkt index 77436f8f4d..42432a561f 100644 --- a/collects/net/ftp-unit.rkt +++ b/collects/net/ftp-unit.rkt @@ -1,213 +1,12 @@ -#lang racket/unit +#lang racket/base ;; Version 0.2 ;; Version 0.1a ;; Micah Flatt ;; 06-06-2002 -(require racket/date racket/file racket/port racket/tcp "ftp-sig.rkt") -(import) -(export ftp^) +(require racket/unit + "ftp-sig.rkt" "ftp.rkt") -;; opqaue record to represent an FTP connection: -(define-struct ftp-connection (in out)) +(define-unit-from-context ftp@ ftp^) -(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") -(define re:response-end #rx#"^[0-9][0-9][0-9] ") - -(define (check-expected-result line expected) - (when expected - (unless (ormap (lambda (expected) - (bytes=? expected (subbytes line 0 3))) - (if (bytes? expected) - (list expected) - expected)) - (error 'ftp "expected result code ~a, got ~a" expected line)))) - -;; 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. -;; -;; While checking, the function sends response lines to -;; diagnostic-accum. This function -accum functions can return a -;; value that accumulates over multiple calls to the function, and -;; accum-start is used as the initial value. Use `void' and -;; `(void)' to ignore the response info. -;; -;; If an unexpected result is found, an exception is raised, and the -;; stream is left in an undefined state. -(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) - (error 'ftp "unexpected EOF")] - [(regexp-match re:multi-response-start line) - (check-expected-result line expected) - (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) - (let loop ([accum (diagnostic-accum line accum-start)]) - (let ([line (read-bytes-line tcpin 'any)]) - (cond [(eof-object? line) - (error 'ftp "unexpected EOF")] - [(regexp-match re:done line) - (diagnostic-accum line accum)] - [else - (loop (diagnostic-accum line accum))]))))] - [(regexp-match re:response-end line) - (check-expected-result line expected) - (diagnostic-accum line accum-start)] - [else - (error 'ftp "unexpected result: ~e" line)]))) - -(define (get-month month-bytes) - (cond [(assoc month-bytes - '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) - (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) - (#"Nov" 11) (#"Dec" 12))) - => cadr] - [else (error 'get-month "bad month: ~s" month-bytes)])) - -(define (bytes->number bytes) - (string->number (bytes->string/latin-1 bytes))) - -(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") - -(define (ftp-make-file-seconds ftp-date-str) - (define date-list (regexp-match re:date (string->bytes/utf-8 ftp-date-str))) - (if (not (list-ref date-list 4)) - (find-seconds 0 0 0 - (bytes->number (list-ref date-list 6)) - (get-month (list-ref date-list 5)) - (bytes->number (list-ref date-list 7))) - (let* ([cur-secs (current-seconds)] - [cur-date (seconds->date cur-secs)] - [cur-year (date-year cur-date)] - [tzofs (date-time-zone-offset cur-date)] - [minute (bytes->number (list-ref date-list 4))] - [hour (bytes->number (list-ref date-list 3))] - [day (bytes->number (list-ref date-list 2))] - [month (get-month (list-ref date-list 1))] - [guess (+ (find-seconds 0 minute hour day month cur-year) tzofs)]) - (if (guess . <= . cur-secs) - guess - (+ (find-seconds 0 minute hour day month (sub1 cur-year)) tzofs))))) - -(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") - -(define (establish-data-connection tcp-ports) - (fprintf (ftp-connection-out tcp-ports) "PASV\r\n") - (let ([response (ftp-check-response - (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"227" - (lambda (s ignore) s) ; should be the only response - (void))]) - (let* ([reg-list (regexp-match re:passive response)] - [pn1 (and reg-list - (bytes->number (list-ref reg-list 5)))] - [pn2 (bytes->number (list-ref reg-list 6))]) - (unless (and reg-list pn1 pn2) - (error 'ftp "can't understand PASV response: ~e" response)) - (let-values ([(tcp-data tcp-data-out) - (tcp-connect (format "~a.~a.~a.~a" - (list-ref reg-list 1) - (list-ref reg-list 2) - (list-ref reg-list 3) - (list-ref reg-list 4)) - (+ (* 256 pn1) pn2))]) - (fprintf (ftp-connection-out tcp-ports) "TYPE I\r\n") - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"200" void (void)) - (tcp-abandon-port tcp-data-out) - tcp-data)))) - -;; Used where version 0.1a printed responses: -(define (print-msg s ignore) - ;; (printf "~a\n" s) - (void)) - -(define (ftp-establish-connection* in out username password) - (ftp-check-response in out #"220" print-msg (void)) - (fprintf out "USER ~a\r\n" username) - (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? - (fprintf out "PASS ~a\r\n" password) - (ftp-check-response in out #"230" void (void)))) - (make-ftp-connection in out)) - -(define (ftp-establish-connection server-address server-port username password) - (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) - (ftp-establish-connection* tcpin tcpout username password))) - -(define (ftp-close-connection tcp-ports) - (fprintf (ftp-connection-out tcp-ports) "QUIT\r\n") - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"221" void (void)) - (close-input-port (ftp-connection-in tcp-ports)) - (close-output-port (ftp-connection-out tcp-ports))) - -(define (ftp-cd ftp-ports new-dir) - (fprintf (ftp-connection-out ftp-ports) "CWD ~a\r\n" new-dir) - (ftp-check-response (ftp-connection-in ftp-ports) - (ftp-connection-out ftp-ports) - #"250" void (void))) - -(define re:dir-line - (regexp (string-append - "^(.)(.*) ((?i:jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)" - " .* [0-9][0-9]:?[0-9][0-9]) (.*)$"))) - -(define (ftp-directory-list tcp-ports [path #f]) - (define tcp-data (establish-data-connection tcp-ports)) - (if path - (fprintf (ftp-connection-out tcp-ports) "LIST ~a\r\n" path) - (fprintf (ftp-connection-out tcp-ports) "LIST\r\n")) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - (list #"150" #"125") void (void)) - (define lines (port->lines tcp-data)) - (close-input-port tcp-data) - (ftp-check-response (ftp-connection-in tcp-ports) - (ftp-connection-out tcp-ports) - #"226" print-msg (void)) - (for*/list ([l (in-list lines)] - [m (in-value (cond [(regexp-match re:dir-line l) => cdr] - [else #f]))] - #:when m) - (define size (cond [(and (equal? "-" (car m)) - (regexp-match #rx"([0-9]+) *$" (cadr m))) - => cadr] - [else #f])) - (define r `(,(car m) ,@(cddr m))) - (if size `(,@r ,size) r))) - -(define (ftp-download-file tcp-ports folder filename) - ;; 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)) - (copy-port tcp-data new-file) - (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))) +(provide ftp@) diff --git a/collects/net/ftp.rkt b/collects/net/ftp.rkt index 5e4ff2a349..6702448612 100644 --- a/collects/net/ftp.rkt +++ b/collects/net/ftp.rkt @@ -1,6 +1,215 @@ #lang racket/base -(require racket/unit "ftp-sig.rkt" "ftp-unit.rkt") -(define-values/invoke-unit/infer ftp@) +(require racket/date racket/file racket/port racket/tcp) -(provide-signature-elements ftp^) +(provide ftp-connection? + ftp-cd + ftp-establish-connection ftp-establish-connection* + ftp-close-connection + ftp-directory-list + ftp-download-file + ftp-make-file-seconds) + +;; opqaue record to represent an FTP connection: +(define-struct ftp-connection (in out)) + +(define re:multi-response-start #rx#"^[0-9][0-9][0-9]-") +(define re:response-end #rx#"^[0-9][0-9][0-9] ") + +(define (check-expected-result line expected) + (when expected + (unless (ormap (lambda (expected) + (bytes=? expected (subbytes line 0 3))) + (if (bytes? expected) + (list expected) + expected)) + (error 'ftp "expected result code ~a, got ~a" expected line)))) + +;; 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. +;; +;; While checking, the function sends response lines to +;; diagnostic-accum. This function -accum functions can return a +;; value that accumulates over multiple calls to the function, and +;; accum-start is used as the initial value. Use `void' and +;; `(void)' to ignore the response info. +;; +;; If an unexpected result is found, an exception is raised, and the +;; stream is left in an undefined state. +(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) + (error 'ftp "unexpected EOF")] + [(regexp-match re:multi-response-start line) + (check-expected-result line expected) + (let ([re:done (regexp (format "^~a " (subbytes line 0 3)))]) + (let loop ([accum (diagnostic-accum line accum-start)]) + (let ([line (read-bytes-line tcpin 'any)]) + (cond [(eof-object? line) + (error 'ftp "unexpected EOF")] + [(regexp-match re:done line) + (diagnostic-accum line accum)] + [else + (loop (diagnostic-accum line accum))]))))] + [(regexp-match re:response-end line) + (check-expected-result line expected) + (diagnostic-accum line accum-start)] + [else + (error 'ftp "unexpected result: ~e" line)]))) + +(define (get-month month-bytes) + (cond [(assoc month-bytes + '((#"Jan" 1) (#"Feb" 2) (#"Mar" 3) (#"Apr" 4) (#"May" 5) + (#"Jun" 6) (#"Jul" 7) (#"Aug" 8) (#"Sep" 9) (#"Oct" 10) + (#"Nov" 11) (#"Dec" 12))) + => cadr] + [else (error 'get-month "bad month: ~s" month-bytes)])) + +(define (bytes->number bytes) + (string->number (bytes->string/latin-1 bytes))) + +(define re:date #rx#"(...) *(.*) (..):(..)|(...) *([0-9]*) +(....)") + +(define (ftp-make-file-seconds ftp-date-str) + (define date-list (regexp-match re:date (string->bytes/utf-8 ftp-date-str))) + (if (not (list-ref date-list 4)) + (find-seconds 0 0 0 + (bytes->number (list-ref date-list 6)) + (get-month (list-ref date-list 5)) + (bytes->number (list-ref date-list 7))) + (let* ([cur-secs (current-seconds)] + [cur-date (seconds->date cur-secs)] + [cur-year (date-year cur-date)] + [tzofs (date-time-zone-offset cur-date)] + [minute (bytes->number (list-ref date-list 4))] + [hour (bytes->number (list-ref date-list 3))] + [day (bytes->number (list-ref date-list 2))] + [month (get-month (list-ref date-list 1))] + [guess (+ (find-seconds 0 minute hour day month cur-year) tzofs)]) + (if (guess . <= . cur-secs) + guess + (+ (find-seconds 0 minute hour day month (sub1 cur-year)) tzofs))))) + +(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)") + +(define (establish-data-connection tcp-ports) + (fprintf (ftp-connection-out tcp-ports) "PASV\r\n") + (let ([response (ftp-check-response + (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"227" + (lambda (s ignore) s) ; should be the only response + (void))]) + (let* ([reg-list (regexp-match re:passive response)] + [pn1 (and reg-list + (bytes->number (list-ref reg-list 5)))] + [pn2 (bytes->number (list-ref reg-list 6))]) + (unless (and reg-list pn1 pn2) + (error 'ftp "can't understand PASV response: ~e" response)) + (let-values ([(tcp-data tcp-data-out) + (tcp-connect (format "~a.~a.~a.~a" + (list-ref reg-list 1) + (list-ref reg-list 2) + (list-ref reg-list 3) + (list-ref reg-list 4)) + (+ (* 256 pn1) pn2))]) + (fprintf (ftp-connection-out tcp-ports) "TYPE I\r\n") + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"200" void (void)) + (tcp-abandon-port tcp-data-out) + tcp-data)))) + +;; Used where version 0.1a printed responses: +(define (print-msg s ignore) + ;; (printf "~a\n" s) + (void)) + +(define (ftp-establish-connection* in out username password) + (ftp-check-response in out #"220" print-msg (void)) + (fprintf out "USER ~a\r\n" username) + (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? + (fprintf out "PASS ~a\r\n" password) + (ftp-check-response in out #"230" void (void)))) + (make-ftp-connection in out)) + +(define (ftp-establish-connection server-address server-port username password) + (let-values ([(tcpin tcpout) (tcp-connect server-address server-port)]) + (ftp-establish-connection* tcpin tcpout username password))) + +(define (ftp-close-connection tcp-ports) + (fprintf (ftp-connection-out tcp-ports) "QUIT\r\n") + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"221" void (void)) + (close-input-port (ftp-connection-in tcp-ports)) + (close-output-port (ftp-connection-out tcp-ports))) + +(define (ftp-cd ftp-ports new-dir) + (fprintf (ftp-connection-out ftp-ports) "CWD ~a\r\n" new-dir) + (ftp-check-response (ftp-connection-in ftp-ports) + (ftp-connection-out ftp-ports) + #"250" void (void))) + +(define re:dir-line + (regexp (string-append + "^(.)(.*) ((?i:jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)" + " .* [0-9][0-9]:?[0-9][0-9]) (.*)$"))) + +(define (ftp-directory-list tcp-ports [path #f]) + (define tcp-data (establish-data-connection tcp-ports)) + (if path + (fprintf (ftp-connection-out tcp-ports) "LIST ~a\r\n" path) + (fprintf (ftp-connection-out tcp-ports) "LIST\r\n")) + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + (list #"150" #"125") void (void)) + (define lines (port->lines tcp-data)) + (close-input-port tcp-data) + (ftp-check-response (ftp-connection-in tcp-ports) + (ftp-connection-out tcp-ports) + #"226" print-msg (void)) + (for*/list ([l (in-list lines)] + [m (in-value (cond [(regexp-match re:dir-line l) => cdr] + [else #f]))] + #:when m) + (define size (cond [(and (equal? "-" (car m)) + (regexp-match #rx"([0-9]+) *$" (cadr m))) + => cadr] + [else #f])) + (define r `(,(car m) ,@(cddr m))) + (if size `(,@r ,size) r))) + +(define (ftp-download-file tcp-ports folder filename) + ;; 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)) + (copy-port tcp-data new-file) + (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))) diff --git a/collects/net/scribblings/ftp.scrbl b/collects/net/scribblings/ftp.scrbl index 7c8fc253db..1bbcaf0387 100644 --- a/collects/net/scribblings/ftp.scrbl +++ b/collects/net/scribblings/ftp.scrbl @@ -88,6 +88,10 @@ file, then moved into place on success).} @section{FTP Unit} +@margin-note{@racket[ftp@] and @racket[ftp^] are deprecated. +They exist for backward-compatibility and will likely be removed in +the future. New code should use the @racketmodname[net/ftp] module.} + @defmodule[net/ftp-unit] @defthing[ftp@ unit?]{