8142ffa4d9
This takes the advice from http://files.stairways.com/other/ftp-list-specs-info.txt further: search for the date by an explicit occurrence of a known month name. This means that we won't see files with bad names (they'd be filtered out of the result), but the filtered out entries are ones that would not be usable with `ftp-make-file-seconds'. When the month is found, and the entry is a file, look for a number preceding the month, and if found, return it as the file size string. This is a minor change in the API. (But it's probably better to either revise it further, or eventually make it irrelevant by exposing the interesting functionality via `net/url'.) original commit: 6a1336e75edff75b7fc8a22a31d776acadc536eb
212 lines
8.8 KiB
Racket
212 lines
8.8 KiB
Racket
#lang racket/unit
|
|
|
|
;; 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^)
|
|
|
|
;; 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 "exected 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))
|
|
(close-output-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)
|
|
(define tcp-data (establish-data-connection tcp-ports))
|
|
(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)))
|