220 lines
8.3 KiB
Scheme
220 lines
8.3 KiB
Scheme
(module ftp-unit mzscheme
|
|
;; Version 0.2
|
|
;; Version 0.1a
|
|
;; Micah Flatt
|
|
;; 06-06-2002
|
|
(require (lib "date.ss")
|
|
(lib "file.ss")
|
|
(lib "port.ss")
|
|
"ftp-sig.ss"
|
|
(lib "unitsig.ss"))
|
|
|
|
(provide net:ftp@)
|
|
(define net:ftp@
|
|
(unit/sig net:ftp^
|
|
(import)
|
|
|
|
;; opqaue record to represent an FTP connection:
|
|
(define-struct tcp-connection (in out))
|
|
|
|
(define tzoffset (date-time-zone-offset (seconds->date (current-seconds))))
|
|
|
|
(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 reponse 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
|
|
[(equal? #"Jan" month-bytes) 1]
|
|
[(equal? #"Feb" month-bytes) 2]
|
|
[(equal? #"Mar" month-bytes) 3]
|
|
[(equal? #"Apr" month-bytes) 4]
|
|
[(equal? #"May" month-bytes) 5]
|
|
[(equal? #"Jun" month-bytes) 6]
|
|
[(equal? #"Jul" month-bytes) 7]
|
|
[(equal? #"Aug" month-bytes) 8]
|
|
[(equal? #"Sep" month-bytes) 9]
|
|
[(equal? #"Oct" month-bytes) 10]
|
|
[(equal? #"Nov" month-bytes) 11]
|
|
[(equal? #"Dec" month-bytes) 12]))
|
|
|
|
(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)
|
|
(let ([date-list (regexp-match re:date (string->bytes/locale ftp-date-str))])
|
|
(if (not (list-ref date-list 4))
|
|
(find-seconds 0
|
|
0
|
|
2
|
|
(bytes->number (list-ref date-list 6))
|
|
(get-month (list-ref date-list 5))
|
|
(bytes->number (list-ref date-list 7)))
|
|
(+ (find-seconds 0
|
|
(bytes->number (list-ref date-list 4))
|
|
(bytes->number (list-ref date-list 3))
|
|
(bytes->number (list-ref date-list 2))
|
|
(get-month (list-ref date-list 1))
|
|
2002)
|
|
tzoffset))))
|
|
|
|
(define re:passive #rx#"\\((.*),(.*),(.*),(.*),(.*),(.*)\\)")
|
|
|
|
(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))])
|
|
(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 (tcp-connection-out tcp-ports) "TYPE I~n")
|
|
(ftp-check-response (tcp-connection-in tcp-ports)
|
|
(tcp-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))
|
|
(display (bytes-append #"USER " (string->bytes/locale username) #"\n") out)
|
|
(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 out #"230" void (void))))
|
|
(make-tcp-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 (tcp-connection-out tcp-ports) "QUIT~n")
|
|
(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)))
|
|
|
|
(define (filter-tcp-data tcp-data-port regular-exp)
|
|
(let loop ()
|
|
(let ([theline (read-bytes-line tcp-data-port 'any)])
|
|
(cond
|
|
[(or (eof-object? theline)
|
|
(< (bytes-length theline) 3))
|
|
null]
|
|
[(regexp-match regular-exp theline)
|
|
=> (lambda (m)
|
|
(cons (cdr m) (loop)))]
|
|
[else
|
|
;; ignore unrecognized lines?
|
|
(loop)]))))
|
|
|
|
(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) (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) (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) (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)
|
|
;; 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 'replace)]
|
|
[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) (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) (tcp-connection-out tcp-ports)
|
|
#"226" print-msg (void))
|
|
(rename-file-or-directory tmpfile (build-path folder filename) #t)))
|
|
|
|
;; (printf "FTP Client Installed...~n")
|
|
)))
|