;;;; vim :ft=lisp
;;;; Touched: <04-Nov-03 06:36:19 IST, madhu>
;;;; Bugs-To: <enometh@net.meer>
;;;; my stripped-down and modified ALLEGRO's FTPD  for personal use.
;;;; Dis-enhancements include:
;;;; - single threaded. reduced use of non ANSI-CL calls.
;;;; - stripped off all UNIXisms, FF calls, external commands.
;;;; - works with Mathew Danish's CL-FTP client
;;;; Limitations include:
;;;; - currently works (only on) CLISP under WIN32 (no UNIX or CYGWIN)
;;;; - #p"/" is broken in CLISP. See comments for *user-accounts*
;;;; - sockets dont time out. yet to test and polish up error handling
;;;;
;;;; (see opensource.franz.com for (> (fork) 0))
;;;; This file is based on allegro ftpd:
;;     <ftpd.cl RCSID:1.25 2002/09/18 20:45:50 dancy>
;;
;; This software is Copyright (c) Franz Inc., 2001-2002.
;; Franz Inc. grants you the rights to distribute
;; and use this software as governed by the terms
;; of the Lisp Lesser GNU Public License
;; (http://opensource.franz.com/preamble.html),
;; known as the LLGPL.
;;;; Dis-enhancements (c) Madhu, 2003
(require 'acl-compat) ; from portableaserve

(defpackage "CL-FTPD"
  (:use "COMMON-LISP")
  (:nicknames "FTPD")
  (:import-from "ACL-COMPAT.EXCL" "IF*" "MATCH-REGEXP"))

(in-package "FTPD")

(defvar *ftpd-version* "1.0.14.madhu.1")

(defclass client ()
  ((sock :initarg :sock :reader client-sock)
   (type :initform :ascii-nonprint :accessor client-type)
   (mode :initform :stream)
   (stru :initform :file)
   (logged-in :initform nil :accessor logged-in)
   (attempts :initform 0 :accessor attempts)
   (user :initform nil :accessor user)
   (pwent :initform nil :accessor pwent)
   (anonymous :initform nil :accessor anonymous)
   (pwd :accessor pwd)
   (addr :initform nil :accessor dataport-addr)
   (port :initform nil :accessor dataport-port)
   (pasv :initform nil :accessor pasv) ;; holds pasv server socket
   (open :initform nil :accessor dataport-open)
   (dsock :initform nil :accessor dataport-sock) ;; holds a connected socket
   (restart :initform 0 :accessor client-restart)
#+nil(umask :initform *default-umask* :accessor client-umask) ;;madhu
   (rename-from :initform nil :accessor rename-from)
   (message-seen :initform (make-hash-table :test #'equal)
		 :accessor message-seen)
   (restricted :initform nil :accessor restricted)
   ))

(eval-when (compile load eval)
  (defstruct cmd
    command
    implemented
    must-be-logged-in
    handler)

  (defparameter *cmds* (make-hash-table :test #'equalp))
  (dolist
      (entry
	  '(;; Login
	    ("user" t nil cmd-user)
	    ("pass" t nil cmd-pass)
	    ("acct" nil nil nil)

	    ;; Logout
	    ("rein" nil nil nil)
	    ("quit" t nil cmd-quit)

	    ;; Transfer parameters
	    ("port" t t cmd-port)
	    ("pasv" t t cmd-pasv)
	    ("mode" t t cmd-mode)
	    ("type" t t cmd-type)
	    ("stru" t t cmd-stru)

	    ;; File action commands
	    ("allo" t t cmd-allo)
	    ("rest" t t cmd-rest)
	    ("stor" t t cmd-stor)
	    ("stou" nil t cmd-stou)
	    ("retr" t t cmd-retr)
	    ("list" t t cmd-list)
	    ("nlst" t t cmd-nlst)
	    ("appe" t t cmd-appe)
	    ("rnfr" t t cmd-rnfr)
	    ("rnto" t t cmd-rnto)
	    ("dele" t t cmd-dele)
	    ("rmd" t t cmd-rmd)
	    ("xrmd" t t cmd-rmd)
	    ("mkd" t t cmd-mkd)
	    ("xmkd" t t cmd-mkd)
	    ("pwd" t t cmd-pwd)
	    ("xpwd" t t cmd-pwd)
	    ("abor" t t cmd-abor)
	    ("cwd" t t cmd-cwd)
	    ("xcwd" t t cmd-cwd)
	    ("cdup" t t cmd-cdup)
	    ("xcup" t t cmd-cdup)
	    ("smnt" nil nil nil)
	    ("mdtm" t t cmd-mdtm)
	    ("size" t t cmd-size)

	    ;; Informational commands
	    ("syst" t t cmd-syst)
	    ("stat" t t cmd-stat)
	    ("help" t t cmd-help)

	    ;; Miscellaneous commands
	    ("site" t t cmd-site)
	    ("noop" t t cmd-noop)))
    (setf (gethash (first entry) *cmds*)
      (make-cmd
       :command (first entry)
       :implemented (second entry)
       :must-be-logged-in (third entry)
       :handler (fourth entry)))))

(defparameter *sitecmds*  nil #+nil ;;madhu
  '(("chmod" . site-chmod) ("umask" . site-umask)))

;;madhu: utilities
(defun iso-8601-date (&key (stream nil)
			   (utime (get-universal-time))
			   (tz (sys::default-time-zone)) ;; CLISP
			   (supress-time-p nil) (supress-tz-p t))
  "Format current datetime (for Common Lisp time-zone TZ) on STREAM."
 (multiple-value-bind (second minute hour date month year day daylight-p zone)
    (decode-universal-time utime tz)
  (declare (ignore day))
  (if daylight-p (decf zone)) ; check
  (format stream "~&~4,'0D-~2,'0D-~2,'0D~:[ ~2,'0D:~2,'0D:~2,'0D~:[ ~C~2,'0D:~2,'0D~;~]~;~]" ;
	  year month date supress-time-p hour minute second supress-tz-p
	  (if (plusp zone) #\- #\+)  (abs (truncate zone))
	  (truncate (* 60 (mod zone 1))))))

;;madhu: bogus
(unless (find-package "UTIL.POSIX-LOCK")
  (defpackage "UTIL.POSIX-LOCK" (:export "WITH-STREAM-LOCK")))

;;madhu: bogus
(unless (fboundp 'util.posix-lock:with-stream-lock)
  (defmacro util.posix-lock:with-stream-lock ((ignorable) &body body)
    (declare (ignorable ignorable))
    `(progn ,@body)))

(defvar *logstream*)
(defvar *xferlogstream*)

(defun ftp-log (&rest args)
  (util.posix-lock:with-stream-lock (*logstream*)
    (when (typep *logstream* 'file-stream) ;;madhu
      (file-position *logstream* :end))
    (format *logstream* "~A [~D]: ~?"
	    (iso-8601-date)#+nil(ctime (unix-time 0) :strip-newline t) ;;madhu
	    0 #+nil(getpid) ;;madhu
	    (first args)
	    (rest args))
    (force-output *logstream*)))

;; config.cl
(defvar *logfile*)
(defvar *xferlog*)
(defvar *debug* :verbose) ;; non-nil means no logfiles.
(defvar *outlinestream*)
;;

;; never call outline w/ a first argument that is anything
;; but a format string.  This macro checks for that situation
;; to be safe.
(defmacro outline (format-string &rest args)
  (let ((ressym (gensym)))
    (when (not (stringp format-string))
      (error "Crikey, format-string is not a string constant: ~s."
	     format-string))
    `(let ((,ressym (format nil ,format-string ,@args)))
       (if (eq *debug* :verbose)
	   (ftp-log "~A~%" ,ressym))
       (write-string ,ressym *outlinestream*)
       (write-char #\return *outlinestream*)
       (write-char #\newline *outlinestream*)
       (force-output *outlinestream*))))

;;;

(defun open-logs ()
  (setf *logstream*
    (if *debug*
	*standard-output*
      (open *logfile*
	    :direction :output
	    :if-does-not-exist :create
	    :if-exists :append)))
  (setf *xferlogstream*
    (if *debug*
	*standard-output*
      (open *xferlog*
	    :direction :output
	    :if-does-not-exist :create
	    :if-exists :append))))

(defun close-logs ()
  (if (not *debug*)
      (progn
	(close *logstream*)
	(close *xferlogstream*))))

(defun xfer-log (client fullpath direction bytes)
  (util.posix-lock:with-stream-lock (*xferlogstream*)
    (when (typep *xferlogstream* 'file-stream) ;;XXX
      (file-position *xferlogstream* :end))
    (format *xferlogstream*
	    "(~A ~A ~S ~S ~D ~S) ;; ~A ~A ~%"
	    (get-universal-time)
	    (ACL-COMPAT.socket:remote-host (client-sock client))
	    fullpath
	    direction
	    bytes
	    (if (anonymous client)
		(anonymous client)
	      (user client))
	    (ACL-COMPAT.socket:ipaddr-to-dotted (ACL-COMPAT.socket:remote-host (client-sock client)))
	    (iso-8601-date)#+nil(ctime (unix-time 0) :strip-newline t))
    (force-output *xferlogstream*)))

(defconstant *telnetIAC* 255)
;;(defconstant *telnetIP* 244)
;;(defconstant *telnetSynch* 242)

(defvar *maxline* 5000)

;; config.cl
;; Control channel timeout.  default -- 5 minutes
(defvar *idletimeout* (* 5 60))
;;

(defun get-request (client)
  (let ((sock (client-sock client))
	(buffer (make-string *maxline*))
	(pos 0)
	lastchar
	gotiac
	longline
	char)
    (ACL-COMPAT.MP:with-timeout (*idletimeout* :timeout)
      (loop

	(if (>= pos *maxline*)
	    (progn
	      (setf longline t)
	      (setf pos 0)))

	(setf char
	  (handler-case (read-char sock)
	    (error ()
	      nil)))

	(if (null char)
	    (return :eof))

        (if (and (char= char #\newline) (eq lastchar #\return))
	    (return (if longline
			:line-too-long
		      (subseq buffer 0 (1- pos)))))

	;;; XXX -- telnet sequences.  Stripped and ignored.
	;;; XXX -- (two-byte sequences, only)
	(if* gotiac
	   then
		(setf gotiac nil)
		(if (= (char-code char) *telnetIAC*)
		    (progn
		      ;; escaped #xff
			      (setf (schar buffer pos) char)
		      (incf pos)
		      (setf lastchar char)))
	   else
		(if (= (char-code char) *telnetIAC*)
		   (progn (warn "madhu:telnetiac!!~&")
		    (setf gotiac t))
		  (progn
		    ;; Regular stuff
		    (setf (schar buffer pos) char)
		    (incf pos)
		    (setf lastchar char))))))))

(defun cleanup-data-connection (client)
  (if (dataport-open client)
      (progn
	(ignore-errors (close (dataport-sock client)))
	(setf (dataport-sock client) nil)
	(setf (dataport-open client) nil)))
  (if (pasv client)
      (progn
	(ignore-errors (close (pasv client)))
	(setf (pasv client) nil)))
  (setf (dataport-addr client) nil)
  (setf (dataport-port client) nil))

(defun cleanup (client)
  (ftp-log "Client from ~A disconnected.~%"
	  (ACL-COMPAT.socket:ipaddr-to-dotted
	   (ACL-COMPAT.socket:remote-host (client-sock client))))
  (cleanup-data-connection client))

(defun dispatch-cmd (client cmdstring)
  (block nil
    (let ((spacepos (position #\space cmdstring))
	  cmdname
	  entry)
      (if (null spacepos)
	  (setf cmdname cmdstring)
	(setf cmdname (subseq cmdstring 0 spacepos)))

      (if (and (not (anonymous client))
	       (equalp cmdname "pass"))
	  (ftp-log "~A: PASS XXXXXX~%"
		  (ACL-COMPAT.socket:ipaddr-to-dotted
		   (ACL-COMPAT.socket:remote-host (client-sock client))))
	(ftp-log "~A: ~A~%"
		(ACL-COMPAT.socket:ipaddr-to-dotted
		 (ACL-COMPAT.socket:remote-host (client-sock client)))
		cmdstring))

      (setf entry (gethash cmdname *cmds*))
      (if (null entry)
	  (return (outline "500 '~A': command not understood." cmdstring)))
      (if (not (cmd-implemented entry))
	  (return (outline "502 ~A command not implemented." cmdname)))
      (if (and (cmd-must-be-logged-in entry)
	       (not (logged-in client)))
	  (return (outline "530 Please login with USER and PASS.")))
      (funcall (cmd-handler entry) client
	       (if spacepos
		   (subseq cmdstring (1+ spacepos))
		 "")))))

;; config.cl
;; The initial connection message.  Some might want to change this for
;; security reasons.
(defparameter *banner* (format nil "Welcome to LA. (Allegro FTP under ~A/~A)"
			       (lisp-implementation-type)
			       (machine-type)))
;;

(defun ftpd-main (sock)
  #+nil(load-config-file) ;;madhu
  (open-logs)
  (ftp-log "Connection made from ~A.~%"
	   (ACL-COMPAT.socket:ipaddr-to-dotted
	    (ACL-COMPAT.socket:remote-host sock)))
  (let ((client (make-instance 'client :sock sock))
	(*outlinestream* sock)
	#+nil(*locale* (find-locale :c)) ;;madhu
	(*print-pretty* nil))
    (handler-case
	(progn
	  #+nil(umask (client-umask client)) ;;madhu
	  (outline "220 ~A" *banner*)
	  (loop
	    (let ((req (get-request client)))
	      (if (eq req :eof)
		  (return (cleanup client)))
	      (if* (eq req :timeout)
		 then
		      (ignore-errors ;; in case the connection disappeared
		       (outline "421 Timeout: closing control connection."))
		      (return (cleanup client)))
	      (if (eq req :line-too-long)
		  (outline "500 Command line too long! Request ignored")
		(if (eq (dispatch-cmd client req) :quit)
		    (return (cleanup client)))))))
      (error (c)
	;(ignore-errors ;; in case the connection disappeared.
	 (outline "421 Error: ~A -- closing control connection."
		  (substitute #\space #\newline (format nil "~A" c)));)
	(ftp-log "Error: ~A.~%" c)
	(signal c))))
  (close-logs))

;; config.cl
;; If you only want to listen on a particular network interface, put
;; it's IP address here (e.g. "192.132.95.151").  If 'nil', all
;; available interfaces will be used.
(defvar *interface* nil) ;; nil means all

(defvar *ftpport* 21)
(defvar *ftpdataport* 20)
;;

;; madhu: force :bivalent as we do a READ-CHAR _and_ want to distinguish
;; between CR LF
(defun standalone-main ()
  (let ((serv (ACL-COMPAT.socket:make-socket :connect :passive
				  :local-host *interface*
				  :local-port *ftpport*
                                  :format :bivalent ;;madhu??
				  :reuse-address t)))
    ;;madhu(socket:configure-dns :auto t)
    (unwind-protect
	(loop
	  (let ((client (handler-case (ACL-COMPAT.socket:accept-connection serv)
			  (interrupt-signal ()
			    (EXT:exit)) ;; CLISP
			  (error ()
			    nil))))
	    (if client ;;madhu: do all serving on the main thread
		(ftpd-main client) #+nil(spawn-client client serv))))
      ;; cleanup forms
      (close serv))))

;;;

(defun ftp-chdir (dir) ;; CLISP
  (ignore-errors (EXT:cd dir)))

(defun cmd-quit (client cmdtail)
  (declare (ignore cmdtail client))
  (outline "221 Goodbye.")
  :quit)

;; config.cl
;; This is the list of login names that are treated as anonymous FTP
;; users.  This parameter must always be a list, even if there is only
;; one login name that you want to treat as anonymous.  The list may
;; be empty if you don't want any login names to be anonymous.
(defvar *anonymous-ftp-names* '("ftp" "anonymous"))

;; All *anonymous-ftp-names* will be mapped to this single
;; *anonymous-ftp-account name.  This account must exist in /etc/passwd
;; and must have a proper home directory (see the README file).
(defvar *anonymous-ftp-account* "ftp")

;; poor man's excuse for an /etc/passwd.
;; NOTES:
;; CLISP Cannot access pathnames like #p"/" with #'EXT:CD on win32.
;; So these must be subdirs and *restricted-users* _must_ be T. Also, use
;; #'truename when setting directories so pathname case is canonicalized.
(defparameter *user-accounts*  ;;madhu XXX mutable;
  (list (list "root"	"root-passwd"	nil) ; disables
	(list "madhu"	""		(truename #p"c:/temp/madhu/"))
	(list "ftp"	""		(truename #p"c:/temp/ftp/")))
  "An alist of (username . pwent) entries.")
;;

(defmacro get-pwent-by-name (name)
  `(cdr (assoc ,name *user-accounts* :test #'string=))) ;;; XXX case

(defmacro pwent-passwd (pwent) `(car ,pwent))
(defmacro pwent-dir (pwent) `(cadr ,pwent))

(defun lookup-account (user) (get-pwent-by-name user))

(defun cmd-user (client user)
  (block nil
    (if (logged-in client)
	(return (outline "530 Already logged in.")))
    (setf (anonymous client) nil)
    (if (and (member user *anonymous-ftp-names* :test #'equalp)
	     (lookup-account *anonymous-ftp-account*))
	(progn
	  (setf user *anonymous-ftp-account*)
	  (setf (anonymous client) t)))
    (setf (user client) user)
    (setf (pwent client) (lookup-account user))
    ;; XXX - Doesn't allow no-password logins.
    (if (anonymous client)
	(outline
	 "331 Guest login ok, send your complete e-mail address as password.")
      (outline "331 Password required for ~A." user))))

;; config.cl
;; *restricted-users* is a list of users who will be confined to their
;; home directories (and deeper) once they successfully login in.
;; Don't overestimate the security of this feature.  See the README file
;; for details.

;; If this parameter is 'nil', no users are restricted.
(defvar *restricted-users* t) ;; FIXME
(defvar *unrestricted-users* nil)
;;

(defun anonymous-setup (client)
  (block nil
    (let ((pwent (pwent client)))
      (if (null (ftp-chdir (pwent-dir pwent)))
	(progn
	  (ftp-log "Failed to chdir(~A)~%" (pwent-dir pwent))
	  (outline "421 Local configuration error.")
	  (return nil)))
      ;;madhu: FIXME -- cant use our chroot hacks as "/" is broken
      #+nil(progn
	(if (not (= 0 (chroot (pwent-dir pwent))))
	  (progn
	    (ftp-log "Failed to chroot(~A)~%" (pwent-dir pwent))
	    (outline "421 Local configuration error.")
	    (return nil)))
	(setf (pwent-dir pwent) "/")
	(setf (pwd client) "/") t)
      ;; madhu: so just honour restrictions instead
      (if (eq *restricted-users* t)
	(if (member (user client) *unrestricted-users* :test #'string=)
	  (setf (restricted client) nil)
	  (setf (restricted client) t))
	(if (member (user client) *restricted-users* :test #'string=)
	  (setf (restricted client) t)))
      )))

;;madhu: bogus
(unless (fboundp 'while)
  (defmacro while (form &body body) `(loop while ,form do ,@body)))

;;madhu: bogus: no errno. set errno to file-error condition
(defmacro ftp-with-open-file ((streamsym errsym path &rest rest) &body body)
  `(let (,errsym)
     (declare (ignorable ,errsym))
     (let ((,streamsym
	    (handler-case (open ,path ,@rest)
	      (file-error (c) (setf ,errsym c) nil))))
       (unwind-protect (progn ,@body)
	 (if ,streamsym (close ,streamsym))))))

;;madhu: bogus
(unless (fboundp 'strerror)
  (defun strerror (&rest rest) (apply #'identity rest)))

(defun dump-msg (client code file)
  (declare (ignore client))
  (block nil
    (if (or (null file)
	    (null (probe-file file)))
	(return))
    (ftp-with-open-file (f errno file)
     (if f
	 (let (line)
	   (while (setf line (read-line f nil nil))
		  (outline "~A-~A" code line)))))))

;; config.cl
;; How long to wait before responding to an invalid password.
(defvar *badpwdelay* 1)

;; How many invalid passwords before we disconnect suddenly.
(defvar *max-password-attempts* 5)

;; If this file exists in the home directory of a user when logging it,
;; it is transmitted.
(defvar *welcome-msg-file* "welcome.msg")
;;

(defun cmd-pass (client pass)
  (block nil
    (let ((pwent (pwent client)))
      (if (logged-in client)
	  (return (outline "530 Already logged in.")))
      (if (null (user client))
	  (return (outline "503 Login with USER first.")))

      #+nil ;;madhu: we're at most servicing one user at a time anyway
      (if* (and *maxusers* (> (probe-pids-file) *maxusers*))
	 then
	      (dump-msg client "530" *toomanymsg*)
	      (outline "530 Connection limit exceeded.")
	      (ftp-log "Connection limit (~D) exceeded.~%" *maxusers*)
	      (return :quit))

      (if* (anonymous client)
	 then
	      (setf (anonymous client) pass)
	 else
	      (if (or (null pwent)
		      (not (string= (pwent-passwd pwent) ;;madhu: XXX
				    pass #+nil(crypt pass (pwent-passwd pwent)))))
		  (return
		    (progn
		      (setf (user client) nil)
		      (setf (pwent client) nil)
		      (sleep *badpwdelay*)
		      (outline "530 Login incorrect.")
		      (incf (attempts client))
		      (if (>= (attempts client) *max-password-attempts*)
			  :quit)))))

      ;; Successful authentication
      (ftp-log "User ~A logged in.~%" (user client))
      (setf (pwd client) (pwent-dir pwent)) ;;madhu

      (if* (anonymous client)
	 then
	      (anonymous-setup client)
	 else
	      ;; If *restricted-users* is 't', then all users are restricted except for those
	      ;; in the *unrestricted-users* list.   Otherwise, a user is restricted if he/she
	      ;; is listed in *restricted-users*.

	      (if* (eq *restricted-users* t)
		 then
		      (if (member (user client) *unrestricted-users* :test #'string=)
			  (setf (restricted client) nil)
			(setf (restricted client) t))
		 else
		      (if (member (user client) *restricted-users* :test #'string=)
			  (setf (restricted client) t))))

      ;; Set up
      #+nil ;;madhu
      (if (not (= 0 (setegid (pwent-gid pwent))))
	  (progn
	    (ftp-log "Failed to setegid(~D)~%" (pwent-gid pwent))
	    (outline "421 Local configuration error.")
	    (return :quit)))

      #+nil ;;madhu
      (if (not (= 0 (initgroups (user client) (pwent-gid pwent))))
	  (progn
	    (ftp-log "Failed to initgroups~%")
	    (outline "421 Local configuration error.")
	    (return :quit)))

      #+nil ;;madhu
      (if (not (= 0 (seteuid (pwent-uid pwent))))
	  (progn
	    (ftp-log "Failed to seteuid(~D)~%" (pwent-uid pwent))
	    (outline "421 Local configuration error.")
	    (return :quit)))

      (if (null (ftp-chdir (pwent-dir pwent))) ;;madhu
	  (progn
	    (ftp-log "Failed to chdir(~A)~%" (pwent-dir pwent))

	    ;; Anonymous/restricted users have no alternative
	    (if (or (anonymous client) (restricted client))
		(progn
		  (outline "421 Local configuration error.")
		  (return :quit)))

	    ;;madhu: FIXME XXX: other users have no alternative either
	    (outline "421 Local Configuration error. Bad policy")
	    (return :quit)

	    #+nil ;;madhu
	    (if (not (ftp-chdir "/"))
		(progn
		  (ftp-log "Failed to chdir(/)~%")
		  (outline "421 Local configuration error.")
		  (return :quit))
	      (progn
		(setf (pwent-dir pwent) "/")
		(outline "230-No directory! Logging in with home=/")))))

      (setf (logged-in client) t)
      (cleanup-data-connection client)
      (dump-msg client "230" *welcome-msg-file*)
      (outline "230 User ~A logged in." (user client)))))

(defun cmd-pwd (client cmdtail)
  (declare (ignore cmdtail))
  (outline "257 \"~A\" is current directory."
	   (pwd client)))

(defun cmd-noop (client cmdtail)
  (declare (ignore client cmdtail))
  (outline "200 NOOP command successful."))

(defun cmd-port (client cmdtail)
  (block nil
    (multiple-value-bind (matched whole a b c d e f)
	(match-regexp
	  "\([0-9]+\),\([0-9]+\),\([0-9]+\),\([0-9]+\),\([0-9]+\),\([0-9]+\)"
	  #+nil"\\([0-9]+\\),\\([0-9]+\\),\\([0-9]+\\),\\([0-9]+\\),\\([0-9]+\\),\\([0-9]+\\)"
	 cmdtail)
      (declare (ignore whole))
      (if (not matched)
	(progn
	  (return (outline "500 'PORT ~A': command not understood." cmdtail))))
      (setf a (parse-integer a))
      (setf b (parse-integer b))
      (setf c (parse-integer c))
      (setf d (parse-integer d))
      (setf e (parse-integer e))
      (setf f (parse-integer f))
      (let ((addr (logior (ash a 24) (ash b 16) (ash c 8) d))
	    (port (logior (ash e 8) f)))
	(if (or (not (= addr (ACL-COMPAT.socket:remote-host (client-sock client))))
		(< port 1024))
	    (return
	      (progn
		(ftp-log "Client from ~A tried to set PORT ~A:~A~%"
			(ACL-COMPAT.socket:ipaddr-to-dotted
			 (ACL-COMPAT.socket:remote-host (client-sock client)))
			(ACL-COMPAT.socket:ipaddr-to-dotted addr)
			port)
		(outline "500 Illegal PORT Command"))))
	(cleanup-data-connection client)
	;;madhu(setf (dataport-addr client) addr)
	(setf (dataport-addr client)
	      (ACL-COMPAT.socket:ipaddr-to-dotted addr))
	(setf (dataport-port client) port)
	(setf (pasv client) nil)
	(outline "200 PORT command successful.")))))

;;config.cl
;; The range of ports used for PASV FTP requests.  You'll either want
;; to change or override these, or update your firewall settings to
;; allow incoming connections to these ports.
(defparameter *pasvrange* '(35000 . 39999))

;; IP address to return in response to PASV command.  This can be left
;; 'nil' for most people.  However, if you have special needs due to
;; network address translation, this can help you.  This parameter
;; should be a list of conses w/ the following layout:
;;   car: string w/ address of network in either a.b.c.d/x.y.z.w
;;        (address/netmask) format or a.b.c.d/x (CIDR) format.
;;   cdr: string w/ PASV IP address to use for clients matching that
;;        network.
;; The IP address reported to the client is chosen from the
;; best match in this list.  Note that this does not affect the IP
;; interface to which the passive connection is bound.  It only
;; controls the address which is reported to the client.  See the
;; README file for additional information and a contrived example.
(defparameter *pasvipaddrs* nil)
;;

;;;; code imported from `ipaddr.cl'
;;;;
(defstruct network-address
  network
  mask)

(defun masklength-to-mask (value)
  (if (stringp value)
      (setf value (parse-integer value)))
  (if (or (< value 0) (> value 32))
      (error "Invalid mask length: ~A" value))
  (- #xffffffff (1- (expt 2 (- 32 value)))))

(defun addr-in-network-p (addr net)
  (if (stringp addr)
      (setf addr (ACL-COMPAT.socket:dotted-to-ipaddr addr)))
  (= (logand addr (network-address-mask net))
     (network-address-network net)))

;; The best match is the one that has the longest network
;; mask (i.e., most on-bits.. which means.. the largest integer value)
(defun best-network-match (addr nets)
  (if (stringp addr)
      (setf addr (ACL-COMPAT.socket:dotted-to-ipaddr addr)))
  (let (best)
    (dolist (net nets)
      (if (addr-in-network-p addr net)
	  (if (null best)
	      (setf best net)
	    (if (> (network-address-mask net)
		   (network-address-mask best))
		(setf best net)))))
    best))
;;;;

(defun get-passive-ip-addr (client)
  (let ((net (best-network-match (ACL-COMPAT.socket:remote-host (client-sock client))
				 (mapcar #'car *pasvipaddrs*))))
    (if (null net)
	(ACL-COMPAT.socket:local-host (client-sock client))
      (cdr (assoc net *pasvipaddrs* :test #'eq)))))

(defun cmd-pasv (client cmdtail)
  (declare (ignore cmdtail))
  (cleanup-data-connection client)
  (let (port sock (tries 0))
    (while (and (null sock)  (< tries 10))
	   (incf tries)
	   ;; XXX -- this could've theoretically looped forever. limit tries.
	   (setf port (+ (car *pasvrange*)
			 ;;  XXX -- (random) always returns the same sequence of numbers.
			 ;; XXX -- need to seed it w/ some random data (/dev/urandom)
			 (random (1+ (- (cdr *pasvrange*) (car *pasvrange*))))))
	   (handler-case (setf sock (ACL-COMPAT.socket:make-socket
				     :type :hiper ;;madhu: WTF is
				     :connect :passive
				     :format
                                     (if (eq (client-type client) :image)
                                       :binary
                                       :text)
				     :local-host *interface*
				     :local-port port))
	     (error #+nil socket-error (c) ;; madhu: FIXME
     	       (ftp-log "~port ~a: Failed to create socket after ~a tries: ~a.~%"
			port tries c) nil #+nil ;;madhu
	       (if (not (eq (stream-error-identifier c) :address-in-use))
		 (signal c) nil))))
    (if (null sock) (error "make-socket: failed after ~a tries!" tries))
    (setf (pasv client) sock)
    (let ((addr (get-passive-ip-addr client)))
      (outline "227 Entering Passive Mode (~D,~D,~D,~D,~D,~D)"
	       (logand (ash addr -24) #xff)
	       (logand (ash addr -16) #xff)
	       (logand (ash addr -8) #xff)
	       (logand addr #xff)
	       (logand (ash port -8) #xff)
	       (logand port #xff)))))

(defun delimited-string-to-list (seq delimiters &key (count nil) (remove-empty-subseqs t) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied)
	&aux (delimiter-or-predicate
	       (etypecase delimiters
		 (character delimiters)
		 (string (if (= (length delimiters) 1)
			   (elt delimiters 0)
			   (lambda (x) (find x delimiters)))))))
  "Return a list of subsequences in SEQ delimited by DELIMITERS

Adapted from SPLIT-SEQUENCE found on CC-LAN and
<http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>

If :remove-empty-subseqs is NIL, empty subsequences will be included in the
result; otherwise they will be discarded. All other keywords work
analogously to those for CL:SUBSTITUTE. The second return value is an index
suitable as an argument to CL:SUBSEQ into the sequence indicating where
processing stopped.

Touched: <05-Nov-03 12:25:36 IST, madhu>
"

  (let ((len (length seq))
        (other-keys (nconc (when test-supplied (list :test test))
                           (when test-not-supplied (list :test-not test-not))
                           (when key-supplied (list :key key)))))
    (unless end (setq end len))
    (loop for left = start then (+ right 1)
	  for right = (min (or (apply (if (functionp delimiter-or-predicate)
					#'position-if #'position)
				      delimiter-or-predicate seq
				      :start left other-keys) len) end)
	  unless (and (= right left) remove-empty-subseqs)
	  if (and count (>= nr-elts count)) return (values subseqs left)
	  else collect (subseq seq left right) into subseqs
	  and sum 1 into nr-elts until (>= right end)
	  finally (return (values subseqs right)))))

(defun cmd-type (client cmdtail)
  (block nil
    (let ((params (delimited-string-to-list cmdtail " "))
          (orig-type (client-type client)) ) ;;madhu XXX
      (cond
       ((or (equalp cmdtail "i") (equalp cmdtail "image"))
	(setf (client-type client) :image)
	(outline "200 Type set to I."))
       ((equalp cmdtail "e")
	(outline "504 Type E not implemented."))
       ((or (equalp (first params) "a") (equalp (first params) "ascii"))
	(if (and (second params)
		 (not (equalp (second params) "n")))
	    (return (outline "504 Form must be N.")))
	(setf (client-type client) :ascii-nonprint)
	(outline "200 Type set to A."))
       ((equalp (first params) "l")
	(if (and (second params)
		 (not (string= (second params) "8")))
	    (return (outline "504 Byte size must be 8.")))
	(setf (client-type client) :local)
	(outline "200 Type set to L (byte size 8)."))
       (t
	(outline "500 'TYPE ~A': command not understood." cmdtail)))
      (when (pasv client) ;;madhu UGH! the asbtraction leaks balls CHECKME
        (unless (eql (eq orig-type :image)
                     (eq (client-type client) :image))
          (warn "madhu: changing element-type on socket-server")
          (setf (ACL-COMPAT.socket::stream-type)
                (if (eq (client-type client) :image)
                  :binary
                  :text))))
       )))

(defun cmd-stru (client cmdtail)
  (declare (ignore client))
  (if (not (member cmdtail '("f" "r" "p") :test #'equalp))
      (outline "500 'STRU ~A': command not understood." cmdtail)
    (if (not (equalp cmdtail "f"))
	(outline "504 Unimplemented STRU type.")
      (outline "200 STRU F ok."))))

(defun cmd-mode (client cmdtail)
  (declare (ignore client))
  (if (not (member cmdtail '("s" "b" "c") :test #'equalp))
      (outline "500 'MODE ~A': command not understood." cmdtail)
    (if (not (equalp cmdtail "s"))
	(outline "504 Unimplemented MODE type.")
      (outline "200 MODE S ok."))))

(defun cmd-rest (client cmdtail)
  (block nil
    (let ((point (ignore-errors (parse-integer cmdtail))))
      (if (null point)
	  (return (outline "500 'REST ~A: command not understood." cmdtail)))
      (if (< point 0)
	  (return (outline "501 'REST ~A: invalid parameter." cmdtail)))
      (setf (client-restart client) point)
      (outline "350 Restarting at ~D. Send STOR or RETR to initiate transfer."
	       point))))

(defun cmd-allo (client cmdtail)
  (declare (ignore client cmdtail))

;; XXX -- pretty useless since asychronous requests aren't supported.
(defun cmd-abor (client cmdtail)
  (declare (ignore cmdtail))
  (cleanup-data-connection client)
  (outline "225 ABOR command successful."))
    (outline "202 ALLO command ignored."))

;; Drops connections made by other hosts.
(defun accept-pasv-connection-from-client (client)
  (loop
    (let ((newsock (ignore-errors (ACL-COMPAT.socket:accept-connection (pasv client)))))
      (if newsock
	  (if (not (= (ACL-COMPAT.socket:remote-host newsock)
		      (ACL-COMPAT.socket:remote-host (client-sock client))))
	      (progn
		(ftp-log "Non-client connection to PASV port ~A:~A made by ~A.~%"
			(ACL-COMPAT.socket:ipaddr-to-dotted
			 (ACL-COMPAT.socket:local-host (client-sock client)))
			(ACL-COMPAT.socket:local-port (pasv client))
			(ACL-COMPAT.socket:ipaddr-to-dotted
			 (ACL-COMPAT.socket:remote-host newsock)))
		(ignore-errors (close newsock)))
	    (return newsock))))))

;;madhu: bogus
(defmacro with-root-privs (&body body) `(progn ,@body))

;; This is covered by the with-timeout in establish-data-connection
(defun make-active-connection (client)
  (handler-case
      (with-root-privs ()
	(ACL-COMPAT.socket:make-socket :remote-host (dataport-addr client)
			    :remote-port (dataport-port client)
			    :format
                            (if (eq (client-type client) :image)
                              :binary
                              :text)
			    :local-host *interface*
			    :local-port *ftpdataport*
			    :reuse-address t
			    :type :hiper))
    (error (c)
      (ftp-log "make-active-connection: make-socket failed; ~A.~%" c)
      nil)))

(defun establish-data-connection (client)
  (block nil
    (setf (dataport-sock client)
      (ACL-COMPAT.mp:with-timeout (*connecttimeout* :timeout)
	(if (pasv client)
	    (accept-pasv-connection-from-client client)
	  (make-active-connection client))))
    (if (null (dataport-sock client))
	(progn
	  (outline "425 Can't open data connection.")
	  (return nil)))
    (if (eq (dataport-sock client) :timeout)
	(progn
	  (outline "425 Can't open data connection.  Timed out.")
	  (return nil)))

    #+nil ;;madhu: FIXME
    (ACL-COMPAT.socket:socket-control
     (dataport-sock client)
     :read-timeout *transfertimeout*
     :write-timeout *transfertimeout*)

    (setf (dataport-open client) t)))

(defun data-connection-prepared-p (client)
  (or (dataport-addr client)
      (pasv client)))

;;madhu: some CL pathname hacks:

;; / ->  nil
;; /a -> (a)
;; /a/b -> (a b)
;; /a/b/ -> (a b)
;; require absolute path
(defmethod path-to-list ((path pathname))
  (let ((components (pathname-directory path))
	(name (file-namestring path)))
    (assert (eq (pop components) :absolute))
    (append components (if name (if (string/= name "") (list name))))))

;; /home/dir/ is within /home/dir.
;; both 'dir' and 'parent' should be absolute names
(defmethod within-dir-p ((dir pathname) (parent pathname)) ;;madhu
  (warn "within-dir-p: dir=~a parent=~a~&" dir parent)
  (let ((dir (path-to-list dir)) (parent (path-to-list parent)))
    (let ((dlen (length dir)) (plen (length parent)))
      (unless (> plen dlen) ;;madhu: XXX case
	(not (mismatch parent (butlast dir (- dlen plen))
		       :test #'string-equal))))))

(defun out-of-bounds-p (client path) ;;madhu
  (not (within-dir-p path (pwent-dir (pwent client)))))

;; If PATH is absolute, return it. otherwise canonicalize PWD+PATH
(defmethod make-full-path ((pwd pathname) (path string))
  (let* ((pwd-items (path-to-list pwd))
	 (path-pathname (pathname path))
	 (path-items (append (pathname-directory path-pathname)
			     (list (file-namestring path-pathname))))
	 (components (ecase (pop path-items)
		       (:absolute path-items)
		       (:relative (append pwd-items path-items))))
	 (canonicals
	   (loop with res for comp in components
		 do (cond ((or (string= comp ".") (string= comp "")))
			  ((string= comp "..") (pop res))
			  (t (push comp res)))
		 finally (return res))))
    (warn "path-items=~s pwd-items=~s components=~s canonicals=~s~&"
	  path-items pwd-items components canonicals)
    (merge-pathnames (let ((car (car canonicals)))
		       (if (and car (stringp car)) (pop canonicals) ""))
		     (make-pathname
		       :name nil :version nil :type nil
		       :directory `(:absolute ,@(reverse canonicals))
		       :defaults pwd))))

;;madhu: adds "trailing slash", whatever that means
(defmethod coerce-to-directory ((path pathname))
  (let ((name (file-namestring path)))
    (if (string/= name "")
      (make-pathname :name nil :version nil :type nil
		     :directory (append (pathname-directory path) (list name))
		     :defaults path)
      path)))

;;madhu: FIXME uncripple
(defun dump-file (client f &aux reader writer)
  (ecase (client-type client)
    (:ascii-nonprint (setq reader #'read-char writer #'write-char))
    ((:image :local) (setq reader #'read-byte writer #'write-byte)))
  (loop for length from 0 for x = (funcall reader f nil)
	while x do (funcall writer x (dataport-sock client))
	finally (return length)))

(defun transmit-stream (client stream name &aux bytes)
  (block nil
    (if (null (establish-data-connection client))
	(return))

    (outline "150 Opening ~A mode data connection for ~A."
	     (if (eq (client-type client) :image)
		 "BINARY" "ASCII")
	     name)

    (if (handler-case (setq bytes (dump-file client stream))
	  (socket-error (c)
	    (outline "426 Data connection: Broken pipe. ~a" c)
	    #+nil ;;madhu: FIXME
	    (if (or (eq (stream-error-identifier c) :read-timeout)
		    (eq (stream-error-identifier c) :write-timeout))
		(outline "426 Data transfer timeout.")
	      (outline "426 Data connection: Broken pipe."))
	    nil)
	  (error (c)
	    (let ((*print-pretty* nil))
	      (outline "426 Error: ~A"
		       (substitute #\space #\newline (format nil "~A" c))))
	    nil))
	(outline "226 Transfer complete."))

    (xfer-log client name :retr bytes #+nil ;;madhu
	      (excl::socket-bytes-written (dataport-sock client)))

    (cleanup-data-connection client)))

(defun cmd-retr (client file)
  (block nil
    (let ((fullpath (make-full-path (pwd client) file)))

      (if (and (restricted client)
	       (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." file)))

      (if (null (data-connection-prepared-p client))
	  (return (outline "452 No data connection has been prepared.")))

      (if (not (probe-file fullpath))
	(return
	  (outline "550 ~A: No such file or directory." file))
	  #+nil ;;madhu: no conversion
	  (multiple-value-bind (conv realname)
	      (conversion-match file)
	    (if conv
		(return (start-conversion client conv realname)))
	    (return (outline "550 ~A: No such file or directory." file))))

      (if (not (eq :file (ACL-COMPAT.excl::filesys-type fullpath)))
	  (return (outline "550 ~A: not a plain file." file)))

      (ftp-with-open-file
       (f errno fullpath ;;madhu: handle TYPE explicitly
	  :element-type (ecase (client-type client)
			  (:ascii-nonprint 'character) ;;madhu: CHECKME
			  ((:image :local) '(unsigned-byte 8))))
       (if (null f)
	   (return (outline "550 ~A: ~A" file (strerror errno))))

       ;; XXX -- this is only correct for binary files.
       (let ((res (ignore-errors
		   (file-position f (client-restart client)))))
	 (setf (client-restart client) 0)
	 (if (null res)
	     (return (outline "550 ~A: RETR (with REST) failed." file))))

       (transmit-stream client f fullpath)))))

;;madhu: FIXME uncripple
(defun store-file (client f &aux reader writer) ;;madhu
  (ecase (client-type client)
    (:ascii-nonprint (setq reader #'read-char writer #'write-char))
    ((:image :local) (setq reader #'read-byte writer #'write-byte)))
  (loop for length from 0 for x = (funcall reader (dataport-sock client) nil)
	while x do (funcall writer x f)
	finally (return length)))

(defun store-common (client file if-exists &aux bytes)
  (block nil
    (let ((fullpath (make-full-path (pwd client) file)))

      (if (not (= 0 (client-restart client)))
	  (return (outline "452 REST > 0 not supported with STOR.")))

      (if (and (restricted client)
	       (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." file)))

      (if (null (data-connection-prepared-p client))
	  (return (outline "452 No data connection has been prepared.")))

;;;(with-umask ((if (and (anonymous client) *quarantine-anonymous-uploads*)
;;;		       #o777
;;;		     (client-umask client))) ... ) ;;madhu
	(ftp-with-open-file
	 (f errno fullpath
	    :direction :output
	    :if-exists if-exists
	    :if-does-not-exist :create
	    :element-type (ecase (client-type client)
			  (:ascii-nonprint 'character) ;;madhu: CHECKME
			  ((:image :local) '(unsigned-byte 8))))
	 (if (null f)
	     (return (outline "550 ~A: ~A" file (strerror errno))))

	 (if (null (establish-data-connection client))
	     (return))

	 (outline "150 Opening ~A mode data connection for ~A."
		  (if (eq (client-type client) :ascii-nonprint)
		      "ASCII" "BINARY")
		  file)

	 (if (handler-case (setq bytes (store-file client f))
	       (socket-error (c)
		 (outline "426 Data connection: Broken pipe. ~a" c)
		 #+nil ;;madhu: FIXME
		 (if (or (eq (stream-error-identifier c) :read-timeout)
			 (eq (stream-error-identifier c) :write-timeout))
		     (outline "426 Data transfer timeout.")
		   (outline "426 Data connection: Broken pipe."))
		 nil)
	       (error (c)
		 (let ((*print-pretty* nil))
		   (outline "426 Error: ~A"
			    (substitute #\space #\newline (format nil "~A" c))))
		 nil))
	     (outline "226 Transfer complete."))

	 (xfer-log client fullpath :stor bytes #+nil ;;madhu
		   (excl::socket-bytes-read (dataport-sock client)))

	 (cleanup-data-connection client)))))

(defun cmd-stor (client file)
  (store-common client file :supersede))

(defun cmd-appe (client file)
  (store-common client file :append))

(defun cmd-syst (client cmdtail)
  (declare (ignore cmdtail client))
  (outline "215 UNKNOWN-LISP") #+nil ;;madhu: FIXME
  (outline "215 UNIX Type: L8"))

;; config.cl
;; If the file exists in any directory a user changes to, it is transmitted.
;; This only happens once per directory for a given connection.
(defparameter *message-file* ".message")
;;

;;; Returns nil if the user is unknown.
(defun expand-tilde (client path)
  (block nil
    (if (not (match-regexp "^~" path))
	(return path))
    (let* ((slashpos (position #\/ path))
	   (name (subseq path 1 slashpos))
	   (dir (if (string= name "")
		    (pwent-dir (pwent client))
		  (let ((pwent (get-pwent-by-name name)))
		    (if (null pwent)
			(return nil)
		      (pwent-dir pwent))))))
      (if (null slashpos)
	  dir
	(make-full-path dir (subseq path slashpos))))))

(defun cmd-cwd (client cmdtail)
  (block nil
    (let ((newpwd (expand-tilde
		   client
		   (if (string= cmdtail "") "~" cmdtail))))

      (if (null newpwd)
	  (return (outline "550 Unknown user name after ~~")))

      (setf newpwd (coerce-to-directory
		     (make-full-path (pwd client) newpwd)))

      (if (and (restricted client)
	       (out-of-bounds-p client newpwd))
	  (return (outline "550 ~A: Permission denied." cmdtail)))

      (if (null (ftp-chdir newpwd))
	  (return (outline "550 ~A: Command failed." cmdtail)))

      (setf (pwd client) (truename newpwd)) ;;madhu: XXX keep canonical

      (if *message-file*
	  (let ((msgfile (make-full-path newpwd *message-file*)))
	    (if (and (probe-file msgfile)
		     (not (gethash msgfile (message-seen client))))
		(progn
		  (setf (gethash msgfile (message-seen client)) t)
		  (ignore-errors
		   (with-open-file (f msgfile)
		     (let (line)
		       (while (setf line (read-line f nil nil))
			      (outline "250-~A" line)))))))))

      (outline "250 ~S is the current directory." newpwd))))

(defun cmd-cdup (client cmdtail)
  (declare (ignore cmdtail))
  (cmd-cwd client ".."))

;;madhu: only support #'directory globs
(defun has-wildcard-p (string)
  (or (find #\* string)
      #+clisp(find #\? string)))

;;madhu: second return value is non-nil if we called #'directory
(defun glob-single (patt pwd)
 (if (string= patt "") (values nil nil)
   (let ((bigpatt (make-full-path pwd patt)))
     (if (char= (char patt (1- (length patt))) #\/) ; XXX
       (setf bigpatt (coerce-to-directory bigpatt)))
     (warn "bigpatt=~a~&" bigpatt)
     (if (not (has-wildcard-p patt))
       (values (list patt) nil)
       (let ((matches (directory bigpatt)))
	 (values (if (null matches)
		   (list patt)
		   (mapcar (lambda (opt) (enough-namestring opt pwd))
			   matches))
		 t))))))

(defun %stat-file (path)
  (with-open-file (stream path)
    `(;; return a destructurable plist
      :length ,(file-length stream)
      :write-date ,(file-write-date stream)
      ,@(let ((author (file-author stream)))
	  (if author (list :author author))) )))

(defun %outline-stats (path)
  (handler-case
    (destructuring-bind
      (&key length write-date &allow-other-keys) (%stat-file path)
      (outline "~A~40T~7D~52T~21T~A" path length
	       (iso-8601-date :utime write-date)))
    (error (c)
      (ftp-log "~a %stat-file: ERROR ~a.~%" path c)
      (outline "~a" path))))

;;madhu: limit globbing and use its results
(defun list-common (client path format-p)
  (block nil
    (multiple-value-bind (options globbed-p) (glob-single path (pwd client))
      (warn "options=~a globbed-p=~a" options globbed-p)
      (if (and (restricted client)
               options
	       (some (lambda (opt)
		       (out-of-bounds-p
			 client
			 (make-full-path (pwd client) opt))) options))
	(return (outline "550 Permission denied.")))

      (if (null (data-connection-prepared-p client))
	  (return (outline "452 No data connection has been prepared.")))

      (if (null (establish-data-connection client))
	  (return))

      (unless globbed-p
	(setq options (if (endp options) ;;madhu: XXX
			(nconc (directory "*/") (directory "*"))
			(directory path)))
	(setq options (mapcar
			(lambda (opt) (enough-namestring opt (pwd client)))
			options))
	(warn "stripped options=~s~&" options))

      (outline "150 Opening ASCII mode data connection for #'directory")

      (let ((*outlinestream* (dataport-sock client)))
	(if format-p ;; this gets ugly
	  (loop for x in options do (%outline-stats x))
	  (outline "~{~A~&~}" options)))

      (cleanup-data-connection client)
      (outline "226 Transfer complete."))))

(defun cmd-list (client path)   (list-common client path t))
(defun cmd-nlst (client path)   (list-common client path nil))

;; XXX - Doesn't do globbing.
(defun cmd-stat-file (client file)
  (block nil
    (if (and (restricted client)
	     (out-of-bounds-p client (make-full-path (pwd client) file)))
	(return (outline "550 ~A: Permission denied." file)))

    (outline "213-status of ~A:" file)
    (%outline-stats file)
    (outline "213 End of Status")))

;; XXX -- according to the spec, this is supposed to work asynchronously.
;; XXX -- I'll probably never work on that.
(defun cmd-stat (client cmdtail)
  (block nil
    (if (not (string= cmdtail ""))
	(return (cmd-stat-file client cmdtail)))

    (outline "211-FTP server status:")
    (outline " Connected to ~A"
	     (ACL-COMPAT.socket:ipaddr-to-dotted
	      (ACL-COMPAT.socket:remote-host (client-sock client))))
    (outline " Logged in as ~A" (user client))
    (if (not (data-connection-prepared-p client))
	(outline " No data connection")
      (if (pasv client)
	  (outline " in Passive mode (~A:~A)"
		   (ACL-COMPAT.socket:ipaddr-to-dotted
		    (ACL-COMPAT.socket:local-host (client-sock client)))
		   (ACL-COMPAT.socket:local-port (pasv client)))
	(outline " PORT (~A:~A)"
		 (ACL-COMPAT.socket:ipaddr-to-dotted (dataport-addr client))
		 (dataport-port client))))
    (outline "211 End of status")))

;; config.cl
;; These options control various restrictions on anonymous users.
#+nil(defparameter *anonymous-chmod-disabled* t) ;;madhu
(defparameter *anonymous-rename-disabled* t)
(defparameter *anonymous-mkdir-disabled* t)
(defparameter *anonymous-rmdir-disabled* t)
(defparameter *anonymous-delete-disabled* t)
;;

;; XXX -- need errno for good error message
(defun cmd-dele (client file)
  (block nil
    (let ((fullpath (make-full-path (pwd client) file)))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." file)))

      (if (not (probe-file fullpath))
	  (return (outline "550 ~A: No such file or directory." file)))

      (if (and (anonymous client) *anonymous-delete-disabled*)
	  (return (outline "553 Delete permission denied.")))

      (if (not (ignore-errors (delete-file fullpath)))
	  (return (outline "550 ~A: Operation failed." file)))

      (outline "250 DELE command successful."))))

;; XXX -- need errno for good error message
(defun cmd-rmd (client file)
  (block nil
    (let ((fullpath (coerce-to-directory
		      (make-full-path (pwd client) file))))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." file)))

      ;;madhu: CHECKME probe-file on dir fails? (perhaps only on / which is ok)
      ;; still avoiding PROBE-DIRECTORY  UGH! CLISP
      (if (not (ignore-errors (probe-file (make-full-path fullpath ""))))
	  (return (outline "550 ~A: No such file or directory." file)))

      (if (and (anonymous client) *anonymous-rmdir-disabled*)
	  (return (outline "553 RMD Permission denied.")))

      (handler-case (EXT:delete-dir fullpath) ;; CLISP
	(system::simple-file-error (c)
	  (return (outline "550 ~A: DEL Operation failed: ~a" file c))))

      (outline "250 RMD command successful."))))

;; XXX -may want to use the 'mode' optional arg to make-directory
(defun cmd-mkd (client newdir)
  (block nil
    (let ((fullpath (coerce-to-directory
		      (make-full-path (pwd client) newdir))))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	  (return (outline "550 MKD Permission denied.")))

      (if (and (anonymous client) *anonymous-mkdir-disabled*)
	  (return (outline "553 MKD Permission denied.")))

      (handler-case (EXT:make-dir fullpath) ;; CLISP
	(system::simple-file-error (c)
	  (return
	    (outline "550 ~A: ~A." newdir c
		     #+nil(strerror (excl::file-error-errno c))))))

      (outline "257 ~S new directory created." fullpath))))

(defun help-main ()
  (outline "214-The following commands are recognized (* =>'s unimplemented).")
  (let ((i 0))
    (maphash
     #'(lambda (key value)
	 (format *outlinestream* "   ~A~A~A"
		 (string-upcase key)
		 (if (not (cmd-implemented value)) "*" " ")
		 (if (= (length key) 3) " " ""))
	 (incf i)
	 (if (= i 8)
	     (progn
	       (outline "")
	       (setf i 0))))
     *cmds*)
    (if (not (= 0 i))
	(outline ""))
    (outline "214 Enjoy.")))

;; doesn't use cmdtail
(defun help-site (client cmdtail)
  (declare (ignore client cmdtail))
  (outline "214-The following SITE commands are recognized.")
  (dolist (ent *sitecmds*)
    (format *outlinestream* "   ~A" (string-upcase (car ent))))
  (outline "")
  (outline "214 Enjoy."))

;;; XXX --- doesn't have help for individual commands.
(defun cmd-help (client cmdtail)
  (block nil
    (if (string= cmdtail "")
	(return (help-main)))
    (let* ((spacepos (position #\space cmdtail))
	   (helpon (if spacepos
		       (subseq cmdtail 0 spacepos)
		     cmdtail)))
      (if (equalp helpon "SITE")
	  (return (help-site client cmdtail)))
      (outline "550 Individual command HELP not implemented."))))

(defun cmd-mdtm (client file)
  (block nil
    (let ((fullpath (make-full-path (pwd client) file)))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." file)))

      (if (not (eq :file (excl::filesys-type file)))
	  (return (outline "550 ~A: not a plain file." file)))

      (if (not (probe-file fullpath))
	  (return (outline "550 ~A: No such file or directory." file)))

      (outline "213 ~A" ; CLISP bug - f-w-d returns local date not universal time
	(make-mdtm-string (file-write-date fullpath))))))

;; YYYYMMDDhhmmss   (in GMT)
(defun make-mdtm-string (&optional (utime (get-universal-time))) ;;madhu
 (multiple-value-bind (second minute hour date month year)
    (decode-universal-time utime 0)
    (format nil "~&~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D"
	    year month date hour minute second)))

(defun cmd-size (client file)
  (block nil
    (let ((fullpath (make-full-path (pwd client) file)))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." file)))

      (if (not (eq :file (excl::filesys-type fullpath)))
	  (return (outline "550 ~A: not a plain file." file)))

      (if (not (probe-file fullpath))
	  (return (outline "550 ~A: No such file or directory." file)))

      (outline "213 ~D" ;;madhu
	       (handler-case 
		 (with-open-file (file fullpath) (file-length file))
		 (error (c) (ftp-log "~a: size ~a~%" fullpath c) 0))))))

(defun cmd-rnfr (client from)
  (block nil
    (let ((fullpath (make-full-path (pwd client) from)))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	  (return (outline "550 ~A: Permission denied." from)))

      (if (not (probe-file fullpath))
	  (return (outline "550 ~A: No such file or directory." from)))

      (setf (rename-from client) from)
      (outline "350 File exists, ready for destination name"))))

(defun rename (from to) ;;madhu
  (handler-case (progn (rename-file from to) 1)
    (file-error (c) (ftp-log "RENAME file-error: ~a.~%" c)0)))

;; Does the actual work.
;; XXX -- need errno info for proper error message.
(defun cmd-rnto (client to)
  (block nil
    (let ((fullpath (make-full-path (pwd client) to)))

      (if (null (rename-from client))
	(return (outline "503 Bad sequence of commands.")))

      (if (and (anonymous client) *anonymous-rename-disabled*)
	(return (outline "553 Rename permission denied.")))

      (if (and (restricted client) (out-of-bounds-p client fullpath))
	(return (outline "550 ~A: Permission denied." to)))

      (if (not (= 0 (rename (rename-from client) to)))
	(outline "550 rename: Operation failed.")
	(outline "250 RNTO command successful."))

      (setf (rename-from client) nil))))

#-nil
(standalone-main)