#!/usr/bin/env newlisp
;; @module mftp
;; @description Enables multiple FTP transfers
;; @author cormullion (cormullion at mac dot com)
;; @author Tim Johnson tim at johnsons-web.com
;; @version 0.12 2008-04-11 2008-04-11 17:20:55 (version history at end)
;; @location http://unbalanced-parentheses.nfshost.com/downloads/ftp.lsp
;;
;; <p>After loading this module, there are two ways to transfer files to an FTP server: 
;; the step by step way, and the all-in-one way.</p>
;; Step by step:
;;
;; @example
;; (context FTP)
;; (connect "ftp.example.com")
;; (config 'quiet nil) 
;; (login "username" "password" "tmp")
;; (send-file "test.txt") ; single file
;; (send-files '("test1.txt" "test2.txt")) ; list of files
;; (get-file "test3.txt") ; single file
;; (get-file "test3.txt" "temp-file-name.txt") ; doesn't overwrite local copy
;; (get-files '("test4.txt" "test5.txt")) ; list of files
;; (logout)
;; (disconnect)

;; All-in-one:
;; 
;; @example
;; (FTP:upload "www.somedomain.com" "me" "mypwd" "/home/remote/me" '("file1.txt" "file2.txt"))
;; (FTP:download "www.somedomain.com" "me" "mypwd" "/home/remote/me" '("file3.txt" "file4.txt"))

(context 'FTP)

(set 'connection-socket1 nil
     'logged-in? nil
     'quiet true
     'report true
     'history nil
     'intro "Connected to host. Upload follows:\n"
     'report-file "Sending: "
     'packet-marker "."
     'control-vars '("quiet" "report" "intro" "report-file" "packet-marker"))

;; @syntax (FTP:config ... <quoted-var1> <val1> <quoted-var1> <val2> ...) 
;; @description Sets control variables. Throws error if var isn't "registered" in 'control-vars 
;; @example 
;; (FTP:config 'quiet 1 'report-file "Uploading: ") => changes FTP:quiet and FTP:report-file 

;; Control variables are as follows:<br> 
;; <quiet>: set to nil to report command transfers<br>
;; <report>: set to non-nil to report and track data transfers<br>
;; <intro>: simple header, displayed if 'report is true<br>
;; <report-file>: precedes announcement of file name when 'report'ing<br>
;; <packet-marker>: one or more characters to print to stdout when a packet is sent<br>
;;
;; NOTE: the intent of config is to 
;; 1) Simplify code 
;; 2) Prevent typos 
;; 3) Create some sort of boundary between "private" and "public" variables.

(define (config)
  (dolist (keyval (explode (args) 2))
      (_config (keyval 0) (keyval 1))))

## Set a control variable, if allowable
(define (_config k val)
  (let ((key (last (parse (string k) ":"))))  ;; remove context prefix
  (if (not (find key control-vars))           ;; set only allowed vars
    (raise (append "key: ['" key "] not in 'control-vars")))
  (set (sym key) val)))

## Raise an error
(define (raise msg)
  (throw-error (append "(FTP context) " msg)))

## Print command port transactions
(define (sh-cmd)
   (if (not quiet) (map (fn (l) (println l)) (args))))

## Print data port transactions
(define (report-data-transfer) ; print progress etc.
  (if report (doargs (i) (print i))))

;; @syntax (FTP:connect <str-server>)
;; @param <str-server> Server name
;; @description Connects to server, used internally by 'upload

(define (connect host (port 21))
   (set 'connection-socket1 (net-connect host port))
   (if (not (positive-complete-response? (get-server-reply)))
           (disconnect)
           true))

;; @syntax (FTP:disconnect)
;; @description Disconnect from server.
(define (disconnect)
   (if logged-in? (logout))
   (net-close connection-socket1))

;; @syntax (FTP:login <str-user-name> <str-password> <str-optional-directory>)
;; @description Log into server
(define (login user-name password (wd "."))
  (and
     (positive-intermediate-response?
      (execute-command-return-code (string "user " user-name)))
     (positive-complete-response?
      (execute-command-return-code (string "pass " password)))
     (set 'logged-in? true)
     (positive-complete-response?
      (execute-command-return-code (string "cwd " wd)))
     (positive-complete-response?
      (execute-command-return-code "type I"))))

;; @syntax (FTP:logout) 
;; @description Send QUIT command.
(define (logout)
   (if (positive-complete-response? (execute-command-return-code (string "quit")))
       (set 'logged-in? nil))
    true)

(define (passive)
  (set 'passive-info (execute-command-get-reply "pasv "))
  (when (positive-complete-response? (just-code passive-info))
    (regex {(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)} passive-info)
    (set 'data-port
       (+ (* 256
           (int $5))
        (int $6)))
    (set 'data-ip (string $1 "." $2 "." $3 "." $4))
    (set 'connection-socket2
       (net-connect data-ip data-port))))

## execute the command and return the three digit response code as an integer
(define (execute-command-return-code command-string)
    (net-send connection-socket1 (append command-string "\r\n"))
    (get-server-reply))

## executes the command and return last line of reply as a string
(define (execute-command-get-reply command-string)
    (net-send connection-socket1 (append command-string "\r\n"))
    (get-full-server-reply))

## Response Predicates
(define (positive-preliminary-response? response)  (<= 100 response 199))
(define (positive-complete-response? response)     (<= 200 response 299))
(define (positive-intermediate-response? response) (<= 300 response 399))
(define (transient-negative-response?  response)   (<= 400 response 499))
(define (permanent-negative-response? response)    (<= 500 response 599))

## Parse code number from response and return integer
(define (just-code response-str)
 (if (< (length response-str) 5)
     (int response-str 0 10)
     (int (0 4 response-str) 0 10)))

## get server's reply to command, and return code (3 digit integer)
(define (get-server-reply) 
  (int (0 3 (get-full-server-reply)) 0 10))

## get server's reply to command, just the last line though, as a string
(define (get-full-server-reply) 
; Get server's reply to command, just the last line though, as a string
    (set 'response (read-input-stream))
    (sh-cmd response)
    (until (and (int (0 3 response)) (= " " (response 3)))
        (begin
            (set 'response (read-input-stream))
            (sh-cmd response)))
    response)

## Get 'chunk' from data port stream
(define (read-input-stream)
     (net-receive connection-socket1 'result 256 "\r\n") result)

## Verify file existence
(define (check-local-file file-name)
    (if (file? file-name)
        true
        (begin
            (sh-cmd file-name " does not exist\n")
            nil)))

;; @syntax (FTP:send-file <str-f>) 
;; @description Upload one file.
(define (send-file f)
  (and
   (check-local-file f)
   (passive)
   (positive-preliminary-response? (execute-command-return-code (string "STOR " f)))
   (report-data-transfer report-file f)
   (set 'fle (open f "r"))
   (while (> (read-buffer fle 'buffer 512) 0)
      (begin
      (net-send connection-socket2 buffer 512)
      (report-data-transfer packet-marker)))
   (report-data-transfer "\n")
   (close fle)
   (net-close connection-socket2)
   (positive-complete-response? (just-code (get-full-server-reply)))))

;; @syntax (FTP:send-files <lst-f-list>)
;; description Upload list of files.
(define (send-files f-list)
  (map send-file f-list)
  (report-data-transfer "Sent " (length f-list) " files"))

;; @syntax (FTP:get-file <str-src-file> <str-optional-dst-file>)
;; @description Get one file, optionally save as different name.
(define (get-file f (fname ""))
  ; can download f to fname to avoid overwriting local copy of f
  (local (local-file)
    (and
       (if (empty? fname)
           (set 'fname f)
           true)
       (passive)
       (if (not (positive-preliminary-response? (execute-command-return-code (string "retr " f))))
           (begin
              (report-data-transfer "file not found")
              (net-close connection-socket2)
              (execute-command-return-code  "stat"))
           (begin
             (set 'local-file (open fname "w")) 
             (while (net-receive connection-socket2 'buffer 512)
                  (begin
                      (write-buffer local-file buffer)
                      (report-data-transfer packet-marker)))
             (close local-file)
             (net-close connection-socket2)
             (positive-complete-response? (just-code (get-full-server-reply))))))))

;; @syntax (FTP:get-files <lst-f-list>)
;; @description Download list of files.
(define (get-files f-list)
  (map get-file f-list))

;; @syntax (FTP:upload <str-host> <str-user-name> <str-password> <str-option-directory> <...files>)
;; @description Connect, log in and transfer in one function call.
;; @return true on success, nil on failure
;; @example
;; (FTP:upload "www.somedomain.com" "me" "mypwd" "/home/remote/me" '("file1.txt" "file2.txt"))

(define (upload host user-name password working-dir)
  (and
   (connect host)
   (login user-name password working-dir)
   (report-data-transfer intro)
   (map send-files (args))
   (trace 1)
   (logout)
   (disconnect)))

;; @syntax (FTP:download <str-host> <str-user-name> <str-password> <str-option-directory> <...files>)
;; @description Connect, log in and download in one function call.
;; @return true on success, nil on failure
;; @example
;; (FTP:download "www.somedomain.com" "me" "mypwd" "/home/remote/me" '("file1.txt" "file2.txt"))

(define (download host user-name password working-dir)
  (and
     (connect host)
     (login user-name password working-dir)
     (map get-files (args))
     (logout)
     (disconnect)))

(context MAIN)

;; <br><h2>Version history</h2>
;; <p>0.12 more fixes                       2008-04-11 17:20:55</p>
;; <p>0.11 more documentation               2008-04-10 11:15:55</p>
;; <p>0.10 initial release                  2008-04-07</p>
;; <p>Based on original code by Lutz and Eddie Rucker.</p>
;; <p>Basic functionality - enabled multiple uploads</p>
;; <p>Added edits, documentation, separated command port reporting from data transfer reporting.</p>
;; <p>Added config function.</p>
;;