;; FTP routines
;; 9-Jun-1999 goetter
;;  ftp-get - fetch a file from anonymous FTP
;;  ftp-put - upload a file to those rare servers that allow it anonymously
;;  ftp-dir - request a directory listing
;; 22-Jul-1999 goetter
;;  macros use gensym
;; 6-Oct-1999 goetter
;;  socket:* routines renamed to tcp:*
;; 6-Nov-1999 goetter
;;  read-line returns eof object at EOF
;; 25-Nov-1999 goetter
;;  read-line on a socket no longer leaves a CR at end of line
;; 25-Oct-2000 goetter
;;  read-raw-vector returns eof object at EOF

;; Anonymity is contained within ftp-login-anon and ftp-get-anon-password.
;; If you extend this, think about the server returning 332 to PASS,
;; and about shrouding any echoed PASS

(require-dll "ss.dll")
(require "exn.scm")

(define-exn exn:ftp)
(define (ftp-abend reason)
 (raise (make-exn:ftp reason '())))


(define-macro (false-on-exn first . rest)
 `(with-handlers (((lambda (x) #t) (lambda (x) #f))) ,first ,@rest))

(define-macro (close-on-exn dataport . body)
 (let ((x (gensym)))
  `(with-handlers (
    ((lambda (x) #t) (lambda (,x) (if ,dataport (close-input-port ,dataport)) (raise ,x)))
                   ) ,@body)))

(define-macro (quit-and-hup-on-exn controlport . body)
 (let ((x (gensym)))
  `(with-handlers (
    ((lambda (x) #t) (lambda (,x) (ftp-quit ,controlport) (close-input-port ,controlport) (raise ,x)))
                   ) ,@body)))


(define *user-password* #f)
(define (ftp-get-anon-password)
 (if *user-password* *user-password*
  (begin
   (display "Email address:")
   (force-output)
   ;; flush stdin of any repl artifact on the console
   (if (and (char-ready?) (eq? (peek-char) #\newline)) (read-char)) 
   (let ((l (read-line)))
    (set! *user-password* (if (eof-object? l) "" l))
    *user-password*))))


;; Flag to handle 1yz return code state.
;; All Pocket Scheme I/O blocks; hence 1yz return codes set this flag.
;; If send-command finds this flag set, it looks for another reply
;; before proceeding with the new command (typically the QUIT on abend).
;; This keeps the commands in sync with the expected replies.
;; Cf. RFC 959 4.2
(define *ftp-another-reply-pending* #f)

;(define *ftp-trace* #t)
(define (ftp-send-command s cmd)
 (if *ftp-another-reply-pending*  (ftp-recv-reply-expected s '() "Out of sync"))
; (if *ftp-trace* (begin (display "---> ") (display cmd) (newline)))
 (display cmd s)
 (display #\x0D s)
 (display #\x0A s)
 (force-output s) )


;; Receive the reply to a command
;; Returns: 
;;  car is list of return code digit chars, 
;;  cadr is string of all text data
;;
(define (ftp-recv-reply s)

 (define (make-retval str revtextlist)
  (set! *ftp-another-reply-pending* (eq? #\1 (string-ref str 0)))
  (list
   (list (string-ref str 0) (string-ref str 1) (string-ref str 2))
   (string-unbreakup (reverse revtextlist) (string #\newline))))

 (set! *ftp-another-reply-pending* #f)
 (let loop ( (line (read-line s)) (endcode #f) (all '()) )
  (if (or (eof-object? line) (and (not endcode) (< (string-length line) 3))) 
   (ftp-abend "Connection prematurely closed by remote peer."))
  ;; Echo
  (display line)
  (newline)
  ;; See RFC 959 4.2, re multiline replies, to justify following mess
  (cond
   ;; First line
   ((not endcode)
    (let ( (replyss (substring line 0 3))
           (sepch (if (> (string-length line) 3) (string-ref line 3) #f))
           (rest (if (> (string-length line) 4) (substring line 4 (string-length line)) #f)) )
     (let ((newall (if rest (cons rest all) all)))
      (if (and sepch (char=? sepch #\-))
       (loop (read-line s) (string->number replyss) newall)
       (make-retval replyss newall)) )))
   ;; Subsequent line, too short to terminate a multiline sequence
   ((< (string-length line) 4)
    (loop (read-line s) endcode (cons line all)) )
   ;; Subsequent line
   (else
    (let ( (replyss (substring line 0 3))
           (sepch (if (> (string-length line) 3) (string-ref line 3) #f)) )
     (if (and sepch (char=? sepch #\space) (let ((x (string->number replyss))) (eq? x endcode)))
      (make-retval replyss 
       (if (> (string-length line) 4) (cons (substring line 4 (string-length line)) all) all))
      (loop (read-line s) endcode (cons line all))) )))) )


(define (match-recv-reply given expected)
 (cond
  ((null? expected) #t)
  ((null? given) #f)
  ((not (eq? (car expected) (car given))) #f)
  (else (match-recv-reply (cdr given) (cdr expected)))))


(define (ftp-recv-reply-expected s val errstr)
 (let ((reply (ftp-recv-reply s)))
  (if (match-recv-reply (car reply) val) #t (ftp-abend errstr))))


;; Auxiliary for recv-reply-pasv
;;
(define (extract-host-and-port data ich-start length-total)
 (let next-num ((num-found 0) (ich-begin ich-start) (found '()))
  (let next-char ((ich-current ich-begin))
   (if (or (= ich-current length-total)
           (not (char-numeric? (string-ref data ich-current))))
    (let ((x (string->number (substring data ich-begin ich-current))))
     (cond
      ((not x) 
       (ftp-abend "Server returned malformed response to PASV"))
      ((= num-found 5) ;; ... so this would be the 6th one. All done!
       (let ((l (reverse (cons x found))))
        ;; Return a list of the address and the port number
        (list
         (string-append
          (number->string (car l)) "."
          (number->string (cadr l)) "."
          (number->string (caddr l)) "."
          (number->string (cadddr l)))
         (let ((l (cddddr l))) (+ (* 256 (car l)) (cadr l))))) )
      (else 
       (next-num (+ num-found 1) (+ ich-current 1) (cons x found)))))
    (next-char (+ ich-current 1))))))


;; Receive the reply to a PASV command
;; Returns the address and port specified by the server
;; 
(define (ftp-recv-reply-pasv s)
 (let ((reply (ftp-recv-reply s)))
  (if (not (match-recv-reply (car reply) '(#\2 #\2 #\7)))
   (ftp-abend "FTP server does not support passive mode")
   (let* ((data (cadr reply)) (length (string-length data)))
    (let loop ((ich 0))
     ;; Find the beginning of the octets, per RFC 1123 4.1.2.6
     (cond
      ((>= ich length) ;; never found them
       (ftp-abend "Server returned malformed response to PASV"))
      ((char-numeric? (string-ref data ich)) ;; found them
       (extract-host-and-port data ich length))
      (else ;; keep looking
       (loop (+ ich 1)))))))))


;; Login to the server, anonymously
;;   
(define (ftp-login-anon s)
 (ftp-send-command s "USER anonymous")
 (let ((reply (ftp-recv-reply s)))
  (case (caar reply)
   ((#\2) ) ;; hunky-dory
   ((#\3)   ;; need password
    (ftp-send-command s (string-append "PASS " (ftp-get-anon-password)))
    (ftp-recv-reply-expected s '(#\2) "Failed to authenticate user") )
   (else    ;; bogus
    (ftp-abend "Failed to authenticate user")))))


;; Send a command, get a data channel in return
;;
(define (ftp-data-channel s cmd)
 (ftp-send-command s "PASV")
 (let ((addr (ftp-recv-reply-pasv s)))
  (ftp-send-command s cmd)
  (let ((datach (false-on-exn (tcp:connect-client (car addr) (cadr addr)))))
   ;; A server may create a data channel - allowing the above connect to succeed -
   ;; then return "550 No such file, dude".
   ;; Or it might claim "125 Ya sure, go on" while in fact never creating the channel.
   ;; On any exception, close the data channel, if opened.

   ;; $REVIEW - is there any possibility of a STOR here returning 226 or 250?
   (close-on-exn datach (ftp-recv-reply-expected s '(#\1) #f))
   (if datach datach (ftp-abend #f)) )))


;; Specify the type of transferred files
;;
(define (ftp-xfer-type s binary?)
 (ftp-send-command s (string-append "TYPE " (if binary? "I" "A")))
 (ftp-recv-reply-expected s '(#\2) "Failed to define file type"))


;; Say good night politely
;;
(define (ftp-quit s)
 (ftp-send-command s "QUIT")
 (ftp-recv-reply-expected s '() "Out of sync"))


;; Call a proc with a control channel to the specified FTP server.
;; Uses anonymous login
;;  
(define (ftp-call-with-control-channel host proc)
 (let ((control (tcp:connect-client host 21)))
  ;; On any exception, send QUIT and hang up
  (quit-and-hup-on-exn control
   (ftp-recv-reply-expected control '(#\2) "Failed to connect to host")
   (ftp-login-anon control)
   (apply proc (list control))
   (ftp-quit control) )
  (close-input-port control)))


;; $REVIEW - consider adding an exception handler to send ABOR

(define (ftp-put host localfile remotefile binary?)
 (with-handlers (
  ((lambda (x) (exn:ftp? x)) 
   (lambda (x) 
    (if (exn:get-message x) (begin (display (exn:get-message x)) (newline)))
    (display "Failed to upload file.") (newline) #f))
                 )
  (ftp-call-with-control-channel host
   (lambda (control)
    (ftp-xfer-type control binary?)
    (let ((datach (ftp-data-channel control (string-append "STOR " remotefile))))
     (call-with-input-file localfile
      (lambda (in)
       (let loop ((bytes (read-raw-vector 1024 'byte in)))
        (if (not (eof-object? bytes))
         (begin
          (write-raw-vector bytes datach)
          (loop (read-raw-vector 1024 'byte in))))))
      'binary)
     (close-output-port datach))
    (ftp-recv-reply-expected control '(#\2) #f)))))


(define (ftp-get host remotefile localfile binary?)
 (with-handlers (
  ((lambda (x) (exn:ftp? x)) 
   (lambda (x) 
    (if (exn:get-message x) (begin (display (exn:get-message x)) (newline)))
    (display "Failed to download file.") (newline) #f))
                 )
  (ftp-call-with-control-channel host
   (lambda (control)
    (ftp-xfer-type control binary?)
    (let ((datach (ftp-data-channel control (string-append "RETR " remotefile))))
     (call-with-output-file localfile
      (lambda (out)
       (let loop ((bytes (read-raw-vector 1024 'byte datach)))
        (if (not (eof-object? bytes))
         (begin
          (write-raw-vector bytes out)
          (loop (read-raw-vector 1024 'byte datach))))))
      'binary)
     (close-input-port datach))
    (ftp-recv-reply-expected control '(#\2) #f)))))


(define (ftp-dir host dir)
 (with-handlers (
  ((lambda (x) (exn:ftp? x)) 
   (lambda (x) 
    (if (exn:get-message x) (begin (display (exn:get-message x)) (newline)))
    (display "Failed to list directory.") (newline) #f))
                 )
  (ftp-call-with-control-channel host
   (lambda (control)
    (ftp-xfer-type control #f)
    (let ((datach (ftp-data-channel control (string-append "LIST " dir))))
     (let loop ((line (read-line datach)))
      (if (not (eof-object? line))
       (begin
        (display line)
        (newline)
        (loop (read-line datach)))))
     (close-input-port datach))
    (ftp-recv-reply-expected control '(#\2) #f)))))