(defclass rsync-translation ()
  ((base :initarg :base :initform (error "base must be populated") :accessor base-of)
   (map-from :initarg :map-from :initform (error "map-from must be populated") :accessor map-from-of)
   (map-to :initarg :map-to :initform (error "map-to must be populated") :accessor map-to-of)
   (password-file :initarg  :password-file :initform nil :accessor password-file-of)
   (port :initarg :port :initform nil :accessor port-of)
   (user :initarg :user :initform nil :accessor user-of)))

(defvar *rsync-translations* nil)

(defun add-rsync-translation (base map-from map-to &key password-file port user)
  (let ((new-translation (make-instance 'rsync-translation
                                        :base base
                                        :map-from map-from :map-to map-to
                                        :password-file password-file :port port :user user)))
    (let ((member-head (member (pathname-directory base) *rsync-translations*
                               :key (lambda (item) (pathname-directory (base-of item)))
                               :test (lambda (a b) (equal a b)))))
      (if member-head
        (setf (car member-head) new-translation)
        (push new-translation *rsync-translations*)))))

(defmacro with-rsync-translations (xlat &body body)
  `(let ((base (base-of ,xlat))
         (map-from (map-from-of ,xlat))
         (map-to (map-to-of ,xlat))
         (password-file (password-file-of ,xlat))
         (port (port-of ,xlat))
         (user (user-of ,xlat)))
     ,@body))

(defun cp (source dest &key password-file port user)
  (sys:call-system-showing-output 
   (format nil
           "rsync ~A ~A rsync://~A~A~A/~A~A"
           (if password-file
             (format nil "--password-file=~A" (namestring password-file))
             "")
           (namestring source)
           (if user (format nil "~A@" user) "")
           (pathname-host dest)
           (if port (format nil ":~A" port) "")
           (pathname-device dest)
           (directory-namestring dest))
   :output-stream nil
   :kill-process-on-abort t
   :show-cmd nil))

(defun subtree-of (path base)
  (let ((path-dir (pathname-directory path))
        (base-dir (pathname-directory base)))
    (loop for base-item on base-dir
          for path-item on path-dir
          unless (and (equal (car base-item) (car path-item))
                      (or (not (cdr base-item))
                          (cdr path-item)))
          do (return nil)
          finally (return t))))

(defun lookup-translation (pathname)
  (find-if (lambda (item) (subtree-of pathname (base-of item)))
           *rsync-translations*))

(defun timestamp ()
  (multiple-value-bind (s m h d mm y) (get-decoded-time)
    (format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D" y mm d h m s)))
  
(defun rsync-file (buffer)
  (unless buffer (setf buffer (editor:current-buffer)))
  (let* ((buffer-pathname (editor:buffer-pathname buffer)))
    (when-let (translation (lookup-translation buffer-pathname))
      (with-rsync-translations translation
        (format t "~&~A: Updating ~A on ~A ... "
                (timestamp)
                (file-namestring buffer-pathname)
                (car (last (pathname-directory base))))
        (cp buffer-pathname
            (merge-pathnames 
             (make-pathname :directory (append '(:relative)
                                               (subseq (pathname-directory buffer-pathname)
                                                       (length (pathname-directory map-from)))))
             map-to)
            :password-file password-file :port port :user user
            )
        (format t "done~%")
        ))))

(editor::add-global-hook editor::write-file-hook 'rsync-file)

; <base>/<map-from>/<path>/file => rsync://<host>/<device>/<map-to>/<path>/file
;    (host, user, pw-file, port are not encoded in the source or destination path)
; so for a given base, need a list of translations:
; host/prefix => host/device/target

(let ((base (make-pathname :directory '(:absolute "big2" "home" "lmc" "work" "employer" "client" "server"))))
  (add-rsync-translation base base
                         (make-pathname :host "localhost" :device "root" :directory '(:absolute))
                         :password-file (merge-pathnames (make-pathname :directory '(:relative :back)
                                                                        :name ".rsync-pw")
                                                         base)
                         :port 1873
                         :user "lmc"))