;;AUTOLOAD: ftp:open
;;AUTODOC: ftp:open "connects as a client to a ftp server"
;;(ftp:open host &key :port :user :password)
;;
;; A mini FTP library
;; This is made primiraly for downloading / recursive retrieval
;; Not all functions may be implemented at first. only the strict necessary 
;; We only implement passive mode, and sending raw commands
;; This lib is patterned along the python ftplib module
;;
;; Usage: 
;; (ftp:open "host" &key (port 21) (user "anonymous") 
;;     (password "ftp@anonymous.com") (root "/") nocd
;; Opens the ftp site in host, and logs to it. Returns a ftp:C connection
;; structure (see defstruct), or () in case of error
;; In case of error, error code is in the global var ftp:open-error, and 
;; text in ftp:open-errortext, as we have no ftp:C structure to store them yet
;; The "host" can also be an URL, which is decodedto extract its fields,
;; in the form [ftp://][user:password@]hostname[:port][/path]
;; :nocd t means do not go to initial directory root "path" on connect
;;
;; High-level functions:
;;======================
;; (ftp:close connection)
;;     closes the connection
;; (ftp:ls connection [dir])
;;     returns a list of files in dir as a list of ftp:F structures
;; (ftp:cd connection dir [:check t])
;;     changes current directory. returns () if failed
;;     If :check, do a pwd just afterwards to check that command was sucecssful
;; (ftp:get connection file)
;;     retrieves a file. returns its contents as a string, or () if failed
;; (ftp:pwd connection)
;;     returns current directory (saved in field pwd of ftp:C)
;;
;; All function can throw to 'EOF, meaning that the connection has been cut
;;
;; Errors are throws to tag ftp:ERROR, with type of error in the field
;; error of ftp:C which can be the keywords:
;;   :temp
;;   :perm
;;   :proto
;;   :reply
;; Last error text is hold in the ftp:C-errortext field of the connection
;; If you define ftp:error-hook, as function taking 3 args:
;; The connection, the error code keyword (:temp, :perm,...), the error text
;; the throw is not done but your code is executed instead
;;
;; Low-level functions
;;====================
;; These may be modified in the future
;;
;; (ftp:voidcmd connection cmd)
;;     Sends a command which do not expect a result, such as "CWD dir"
;; (ftp:retrlines connection)
;;     Sends a command which expects a result, which is returned as a
;;     string of concatenated lines, such as "LIST dir"
;; (ftp:retrbinary connection command buffer &key (blocksize 8192))
;;     Sends a command that will, in passive mode, open a sub-connection to 
;;     fill in place buffer, such as "RETR filename" 
;; (ftp::open-file (connection cmd)
;;     Opens a distant file to retrieve, returns the file descriptor to it
;; (ftp:close-file (connection fd)
;;     Closes a fd opened with the above ftp:open-file. needed to reset the
;;     FTP protocol
;; ftp:linelength is set to 512 and represents the maximum line length of
;;     FTP commands

(setq *package* 'ftp)

;;globals
(defvar %port 21)			;default port
(defvar %newline "\r\n")
(defvar Verbose ())			;if set, show every packet
(defvar ftp:linelength 512)
(defvar ftp:anonymous-pass "ftp@anonymous.com")

;; structures
(defstruct ftp:C
  host					;connection parameters: host/port/...
  user
  passwd
  acct
  port
  pwd					;cache of current dir
  fd					;the main connection fd
  mode					;last mode: "I" (binary) or "A" (ascii)
  root					;the initial dir at connection
  lastrep				;last protocol response
  error					;last error
  errortext				;last error text
  welcome				;welcome banner of site
  size					;size of last request. can be ()
)

(defstruct ftp:F
  name
  size					;Int. () if we couldnt parse dir info
                                        ; "" for dirs
  date
  flags
  type					;first char of flags
  user
  group 
  links
)

;;=============================================================================
;;                    High level functions
;;=============================================================================

;; returns an opened connection (ftp:C structure) , or ()
(defun ftp:open (host &key 
    (port 21) 
    (user "anonymous") 
    (password ftp:anonymous-pass)
    (root "/") 
    nocd
    &aux c fd conn
    (failed-to-open t)
    cderr
  )
  (catch 'EOF
    (catch 'ftp:OpenError
      (if (not (ftp:re-purehostname host))
	(ftp:decode-url host 'host 'port 'user 'password 'root)
      )
      (if (setq fd (open (+ host ":" port) :buffered ()
	    :type :tcp :direction :io :blocking t :error ())) (progn
	  (setq c (make-ftp:C :host host :user user :passwd password :port port
	      :pwd "/" :fd fd :acct "" :mode () :root root
	  ))
	  (setqn ftp:open-error () ftp:open-errortext "")
	  (catch 'ftp:ERROR
	    (ftp:C-welcome c (ftp:getresp c))
	    (ftp:login c)
	    (if (and (not nocd) (/= root "/")) (progn
		(ftp:voidcmd c (+ "CWD " root))
		c.pwd = root
	    ))
	    (setq conn c)
	  )
	  (if (not conn) (progn
	      (setq ftp:open-error (ftp:C-error c))
	      (setq ftp:open-errortext (ftp:C-errortext c))
	      (close fd)
	  ))
	  (setq failed-to-open ())
  ))))
  (if failed-to-open (progn
      ;; could not connect to host at all
      (setq ftp:open-error :proto)
      (if ftp:open-error
	(setq ftp:open-errortext "XXX - cannot connect to host")
	(setq ftp:open-errortext "XXX - connection cut")
      )
      ()
    )
    conn
))

(defun ftp:close (c)
  (close (ftp:C-fd c))
)

;; List directory (default = current)
;; Returns a list of structs ftp:F, excluding . and ..
;; Unix form. Date is either:
;;     MonthName Day HH:MM
;;     MonthName Day YYYY
(setq ftp:re-ls (regcomp (+
      "^([^ \t0-9]+)[ \t]*([0-9]+)[ \t]+([^ \t]+)[ \t]+([^ \t]+)[ \t]+"
      "([0-9]+)[ \t]+([a-zA-Z][a-zA-Z][a-zA-Z][ \t]+[0-9]+[ \t]+"
      "[0-9:]+) (.*)$"
)))
(setqn ftp:re-ls-flags 1 ftp:re-ls-links 2 ftp:re-ls-user 3 ftp:re-ls-group 4
  ftp:re-ls-size 5 ftp:re-ls-date 6 ftp:re-ls-file 7
)
(setq ftp:re-ls2 (regcomp (+
      "^([^ \t0-9]+)([ \t]+)([^ \t]+)[ \t]+([^ \t]+)[ \t]+"
      "([0-9]+)[ \t]+([a-zA-Z][a-zA-Z][a-zA-Z][ \t]+[0-9]+[ \t]+"
      "[0-9:]+) (.*)$"
)))

(setq ftp:re-ls-total (regcomp "^total[ \t]+[0-9]+$"))
(setq ftp:re-ls-hidden (regcomp "^[.][.]?$"))

;; A variant of some windows servers
;; Date is ?
;; generic win form
(setq ftp:re-ls-win (regcomp (+	;date
      "^([0-9][0-9]-[0-9][0-9]-[0-9][0-9]  [0-9][0-9]:[0-9][0-9][aApP][mM])"
      "[ \t\r]+(<[dD][iI][rR]> *|[0-9]+) " ;<DIR> + spaces or filesize
      "(.*)$"				;filename
)))
(setq ftp:re-ls-win1 (regcomp (+	;date
      "^([0-9][0-9]-[0-9][0-9]-[0-9][0-9]  [0-9][0-9]:[0-9][0-9][aApP][mM])"
      "[ \t\r]+(<[dD][iI][rR]>        |[0-9]+) " ;<DIR> + 9spaces or filesize
      "(.*)$"				;filename
)))
(setq ftp:re-ls-win2 (regcomp (+	;date
      "^([0-9][0-9]-[0-9][0-9]-[0-9][0-9]  [0-9][0-9]:[0-9][0-9][aApP][mM])"
      "[ \t\r]+(<[dD][iI][rR]>         |[0-9]+) " ;<DIR> +10 spaces or filesize
      "(.*)$"				;filename
)))
(setq ftp:re-size (regcomp "^[0-9]+$"))

(defun ftp:ls (c &optional dir
    &aux lines (files (vector)) 
    (win-re ftp:re-ls-win)		;in win case, which re form?
  )
  (setq dir (ftp:protect-space c dir))
  (setq lines (if dir (ftp:retrlines c (+ "LIST " dir))
      (ftp:retrlines c "LIST")
  ))
  (dolist (line lines)
    (if Verbose (verbose? "%r0" line))
    (if					;we try to interpret LS results...
      (regexec ftp:re-ls-total line)	;header
      ()

      (regexec ftp:re-ls line)		;unix form
      (with (file (regsub ftp:re-ls ftp:re-ls-file))
	(if (not (regexec ftp:re-ls-hidden file)) ;skip . & ..
	  (lappend files
	    (make-ftp:F 
	      :name file
	      :size (ftp::parse-size (regsub ftp:re-ls ftp:re-ls-size))
	      :date (regsub ftp:re-ls ftp:re-ls-date)
	      :flags (regsub ftp:re-ls ftp:re-ls-flags)
	      :type (0 line)
	      :user (regsub ftp:re-ls ftp:re-ls-user)
	      :group (regsub ftp:re-ls ftp:re-ls-group)
	      :links (regsub ftp:re-ls ftp:re-ls-links)
      ))))

      (regexec ftp:re-ls2 line)		;unix form, no count of links
      (with (file (regsub ftp:re-ls2 ftp:re-ls-file))
	(if (not (regexec ftp:re-ls-hidden file)) ;skip . & ..
	  (lappend files
	    (make-ftp:F 
	      :name file
	      :size (ftp::parse-size (regsub ftp:re-ls2 ftp:re-ls-size))
	      :date (regsub ftp:re-ls2 ftp:re-ls-date)
	      :flags (regsub ftp:re-ls2 ftp:re-ls-flags)
	      :type (0 line)
	      :user (regsub ftp:re-ls2 ftp:re-ls-user)
	      :group (regsub ftp:re-ls2 ftp:re-ls-group)
	      :links (regsub ftp:re-ls2 ftp:re-ls-links)
      ))))
      
      (regexec win-re line)	;Windows braindead form
      (with (re (ftp::win-form) 
	  isdir? (= #\< (0 (win-re 2))))
	(lappend files
	  (make-ftp:F 
	    :name (win-re 3)
	    :size (if isdir? "" (ftp::parse-size (win-re 2)))
	    :date (win-re 1)
	    :flags (if isdir? "drwxrwxr-x" "-rwxrwxr-x")
	    :type (if isdir? #\d #\-)
	    :user "none"
	    :group "none"
	    :links 0
      )))

      t (PF *stderr* "*** Unknown dir entry: %r0\n" line)
  ))
  files
)

(defun ftp::win-form ()
  (if (eq win-re ftp:re-ls-win) (progn	;didnt choose yet
      (setq win-re ftp:re-ls-win2)
      (dolist (line lines)
	(if (not (ftp:re-ls-win2 line))
	  (setq win-re ftp:re-ls-win1)
      ))
      (if Verbose (verbose? "win form is %0"
	  (if (eq win-re ftp:re-ls-win1) 1 2)
      ))
      (if (not (win-re line))
	(PF *stderr* "*** Unknown dir entry: %r0\n" line)
      )
  ))
  win-re
)

(defun ftp::parse-size (string)
  (if (ftp:re-size string) (Int string) ())
)

;; Change current dir, return t if ok, () if not
(defun ftp:cd (c dir &key (check ()) &aux ok (oldpwd c.pwd))
  (setq dir (ftp:protect-space c dir))
  (catch 'ftp:ERROR
    (ftp:voidcmd c (+ "CWD " dir))
    (if check
      ;; we check that the cd actually moved us somewhere!
      ;; in some cases, cd seems to work but stay in current dir
      (if (not (or  (and (= #\/ (0 dir)) (= oldpwd dir)) ;identical absolute
	    (and (/= #\/ (0 dir)) (= dir ""))	;empty dir
	))
	(if (= oldpwd c.pwd) 
	  (ftp:error c :perm 
	    (PF String "CD into \"%0\" made us stay in \"%1\"!" dir oldpwd)
    ))))
    (setq c.pwd (concat-paths c.pwd dir)) ;update pwd in c structure
    (setq ok t)
  )
  ok
)

;; Get file into a buffer. returns () in case of error, or file contents
;; :from uses the REST command, if not implemented by the server, will
;; return an error, and the ftp:C-errortext will be something like:
;; 502 REST command not implemented.
(defun ftp:get (c filename &key from &aux (buffer (copy "")) ok)
  (catch 'ftp:ERROR
    (ftp:retrbinary c (+ "RETR " filename) buffer :from from)
    (setq ok t)
  )
  (if ok buffer ())
)

;; gets current dir and returns it. also set c.pwd to it
(setq ftp:pwd:re (regcomp "^2[0-9][0-9] \"(.*)\" is[^\"]*$"))
(defun ftp:pwd (c &aux resp)
  (ftp:voidcmd c "PWD")
  (if (ftp:pwd:re (setq resp (ftp:voidcmd c "PWD")))
    c.pwd = (ftp:pwd:re 1)
    (ftp:error c :perm resp)
  )
  c.pwd
)

;; Change current dir to .., return t if ok, () if not
(defun ftp:cdup (c &aux ok)
  (catch 'ftp:ERROR
    (ftp:voidcmd c "CDUP")
    (when (ftp:cdup-re c.pwd) 
      (setq ok t)
      c.pwd = (ftp:cdup-re 1)
    )
  )
  ok
)
ftp:cdup-re = (regcomp "^(.*)[/][^/]+[/]?$")

;;=============================================================================
;;                    Low level functions
;;=============================================================================
;; Throw an error
(defvar ftp:error-hook)
(defun ftp:error (c code text)
  (ftp:C-error c code)
  (ftp:C-errortext c text)
  (if ftp:error-hook
    (ftp:error-hook c code text)
    (throw 'ftp:ERROR text)
  )
)

;; get a response from a connection
(defun ftp:getresp (c &aux resp c1)
  (setq resp (ftp:getmultiline c))
  (ftp:C-lastrep c (subseq resp 0 3))
  (setq c1 (0 resp))
  (if (= c1 #\4) (ftp:error c :temp resp)
    (= c1 #\5) (ftp:error c :perm resp)
    (not (seek "123" c1)) (ftp:error c :proto resp)
  )
  resp
)

;; get a multine response
(defun ftp:getmultiline (c &aux line (go-on t) nextline)
  (setq line (ftp:getline c))
  (if (= (3 line) #\-) 
    (with (code (subseq line 0 3))
      (while go-on
	(setq nextline (ftp:getline c))
	(nconc line "\n" nextline)
	(if (and (= code (subseq nextline 0 3))
	    (/= #\- (3 nextline))
	  )
	  (setq go-on ())
  ))))
  line
)

(defun ftp:sendcmd (c cmd)
  (ftp:putcmd c cmd)
  (ftp:getresp c)
)

(defun ftp:voidcmd (c cmd)
  (ftp:putcmd c cmd)
  (ftp:voidresp c)
)

(defun ftp:partialcmd (c cmd)
  (ftp:putcmd c cmd)
  (ftp:partialresp c)
)

(defun ftp:partialresp (c &aux resp)
  (setq resp (ftp:getresp c))
  (if (/= #\3 (0 resp))
    (ftp:error c :reply resp)
  )
  resp
)

(defun ftp:open-file (c cmd &key from)
  (ftp:mode c "I")
  (ftp:transfercmd c cmd :from from)
)

(defun ftp:close-file (c conn)
  (close conn)
  (ftp:voidresp c)
)

(defun ftp:voidresp (c &aux resp)
  (setq resp (ftp:getresp c))
  (if (/= #\2 (0 resp))
    (ftp:error c :reply resp)
  )
  resp
)

(defun ftp:login (c &aux resp)
  (setq resp (ftp:sendcmd c (+ "USER " (ftp:C-user c))))
  (if (= #\3 (0 resp)) (setq resp (ftp:sendcmd c (+ "PASS " (ftp:C-passwd c)))))
  (if (= #\3 (0 resp)) (setq resp (ftp:sendcmd c (+ "ACCT " (ftp:C-acct c)))))
  (if (/= #\2 (0 resp)) (ftp:error c :reply resp))
  resp
)

(defmacro ftp:trap-error (trap-form &rest forms &aux ok)
  `(with (ftp:trap-error-err t)
    (catch 'ftp:ERROR
      ,@forms
      (setq ftp:trap-error-err ())
    )
    (if ftp:trap-error-err ,trap-form)
))

;;=============================================================================
;;                    Real low-level "fiber" commands
;;=============================================================================

(setq ftp:re-ff (regcomp "\xff"))

(defun ftp:putcmd (c cmd)
  (if (> (length cmd) (- ftp:linelength 2))
    (ftp:error c :proto (PF String "Line length too long: %0" (length cmd)))
  )
  (if Verbose (verbose? "##> %r0" cmd))
  (if (ftp:re-ff cmd)			;for telnet, quote %ff (ascii 255)
    (replace-string cmd ftp:re-ff "\xff\xff" :all t :quote t)
  )
  (write-string (+ cmd "\r\n") (ftp:C-fd c))
  (flush (ftp:C-fd c))
)

(setq %re-eoltrim (regcomp "[\n\r]+$"))
(defun ftp:getline (c &aux line)
  (setq line (read-line (ftp:C-fd c)))
  (if (regexec %re-eoltrim line)
    (setq line (subseq line 0 (0 (get %re-eoltrim 0))))
  )
  (if Verbose (verbose? "<## %r0" line))
  line
)

;; should return a fd
;; response to PASV: 227 Entering Passive Mode (127,0,0,1,26,64)
(setq ftp:re-227 (regcomp 
    "^227[^(]*[(]([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)[)]"
))
(setq ftp:re150 (regcomp "150 .* ([0-9]+) +bytes"))

(defun ftp:transfercmd (c cmd &key from &aux resp ip port fd)
  (if (not (ftp:re-227 (setq resp (ftp:sendcmd c "PASV"))))
    (ftp:error c :proto resp)
  )
  (setq ip
    (+ (ftp:re-227 1) "." (ftp:re-227 2) "." (ftp:re-227 3) "." (ftp:re-227 4))
  )
  (setq port (String (+ (* 256 (Int (ftp:re-227 5))) (Int (ftp:re-227 6)))))
  ;; in the current implementation, :input is sufficient
  (setq fd (open (+ ip ":" port) :type :tcp :direction :input :error ()))
  (if (not fd) (ftp:error c :perm resp))
  (if from (ftp:partialcmd c (+ "REST " (String from))))
  (setq resp (ftp:sendcmd c cmd))
  (if (/= #\1 (0 resp)) (ftp:error c :reply resp))
  (if (ftp:re150 resp)
    (ftp:C-size c (Int (ftp:re150 1)))
    (ftp:C-size c ())
  )
  fd
)

(defun ftp:mode (c mode)		;"A" or "I"
  (if (/= mode (ftp:C-mode c)) (progn
      (ftp:C-mode c mode)
      (ftp:voidcmd c (+ "TYPE " mode))
)))
	
(defun ftp:retrlines (c cmd &aux conn (lines (list)))
  (ftp:mode c "A")
  (setq conn (ftp:transfercmd c cmd))
  (while (setq line (read-line conn ()))
    (if (regexec %re-eoltrim line)
      (setq line (subseq line 0 (0 (get %re-eoltrim 0))))
    )
    (lappend lines line)
  )
  (close conn)
  (ftp:voidresp c)
  lines
)

;;stores into user-provided buffer
;;A more sophiticated function would allow callbacks, and multiple 
;;connections at once
(defun ftp:retrbinary (c cmd buffer &key (blocksize 8192) from
    &aux conn data (go-on t)
  )
  (ftp:mode c "I")
  (setq conn (ftp:transfercmd c cmd :from from))
  (catch 'EOF
    (while go-on
      (setq data (read-chars blocksize conn))
      (if (not data) 
	(setq go-on ())
	(nconc buffer data)
  )))
  (close conn)
  (ftp:voidresp c)
)

;;=============================================================================
;;                    Misc util functions
;;=============================================================================
(setq ftp:re-purehostname (regcomp "^[-_.a-zA-Z0-9]+$"))

(setq ftp:re-url (regcomp "^(ftp://)?([^/]+)([/].*|)$"))
(setq ftp:re-host-port (regcomp "^(.+):([0-9]+)$"))
(setq ftp:re-host-userpass (regcomp "^([^:]+):(.*)@([^@:]*)$"))
(setq ftp:re-octal-host (regcomp (+ "^"
      "(0[0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)|"
      "([0-9]+[.]0[0-9]+[.][0-9]+[.][0-9]+)|"
      "([0-9]+[.][0-9]+[.]0[0-9]+[.][0-9]+)|"
      "([0-9]+[.][0-9]+[.][0-9]+[.]0[0-9]+)" "$"
)))
(setq ftp:re-num-host (regcomp "^([0-9]+)[.]([0-9]+)[.]([0-9]+)[.]([0-9]+)$"))

(defun ftp:decode-url (hostname host-var port-var user-var passwd-var root-var
  )
  (set host-var (html:unquote-values hostname))
  (if (ftp:re-url (eval host-var)) (progn
      (set host-var (ftp:re-url 2))
      (when (ftp:re-host-port (eval host-var)) 
	(set port-var (Int (ftp:re-host-port 2)))
	(set host-var (ftp:re-host-port 1))
      )
      (if (or (not (eval port-var)) (<= (eval port-var) 0))
	(set port-var 21)
      )
      (when (ftp:re-host-userpass (eval host-var))
	(set user-var (ftp:re-host-userpass 1))
	(set passwd-var (ftp:re-host-userpass 2))
	(set host-var (ftp:re-host-userpass 3))
      )
      (set root-var (ftp:re-url 3))
      (if (= "" (eval root-var)) (set root-var "/"))
      (if (and (ftp:re-octal-host (eval host-var))
	  (ftp:re-num-host (eval host-var))
	)
	(set host-var (+ 
	    (dec-or-oct (ftp:re-num-host 1)) "."
	    (dec-or-oct (ftp:re-num-host 2)) "."
	    (dec-or-oct (ftp:re-num-host 3)) "." 
	    (dec-or-oct (ftp:re-num-host 4))
      )))
    )
    (throw 'ftp:OpenError)		;parse error
  ) 
)
    
(defun dec-or-oct (s)
  (if ({regcomp "^0"} s) (String (otoi (Int s))) s)
)


;; some ftpd trim leading/trailing whitespace from dir. We protect them by
;; prepending pwd or terminating by /
;; returns the new value (possibly inchanged)

(defun ftp:protect-space (c dir)
  (when dir
    (if ({regcomp "^[ \t\r\n]"} dir)
      (setq dir (concat-paths c.pwd dir))
    )
    (if ({regcomp "[ \t\r\n]$"} dir)
      (setq dir (+ dir "/"))
    )
  )
  dir
)

;; test case for debugging
;;(defun main ()
;;  (setq c (ftp:open "localhost"))
;;  (dolist (line (ftp:retrlines c "LIST"))
;;    (write-line line)
;;  )
;;  (setq buffer (copy ""))
;;  (ftp:retrbinary c "RETR welcome.msg" buffer)
;;  (write-line buffer)
;;)
  
