;;; vc-backup.el --- VC backend for versioned backups  -*- lexical-binding: t; -*-

;; Copyright (C) 2021  Free Software Foundation, Inc.

;; Author: Philip Kaludercic <philipk@posteo.net>
;; Version: 1.0.0
;; Keywords: vc

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Find here a VC backend that uses backup files for versioning.  It
;; is recommended to enable `version-control' and related variables,
;; to make the most use of it.
;;
;; To install this VC backend, evaluate
;;
;;	(add-to-list 'vc-handled-backends 'Backup t)
;;
;; or add it to your initialisation file.
;;
;; There is no need or ability to manually "commit" anything, as
;; backups should be generated automatically.  To force a backup, read
;; up on the documentation of `save-buffer'.  Backups can be viewed
;; using the command `vc-print-log'.

;;; Code:

(eval-when-compile
  (require 'subr-x)
  (require 'rx))
(require 'files)
(require 'cl-lib)
(require 'diff)
(require 'vc)
(require 'log-view)

(defconst vc-backup-current-tag "real"
  "Tag used for the actual file.")
(defconst vc-backup-previous-tag "prev"
  "Tag used for unversioned backup.")

(defun vc-backup-get-read (file-or-backup)
  "Return the actual file behind FILE-OR-BACKUP."
  (if (backup-file-name-p file-or-backup)
      (replace-regexp-in-string
       "!!?"
       (lambda (rep)
	 (if (= (length rep) 2) "!" "/"))
       (file-name-nondirectory
	(file-name-sans-versions file-or-backup)))
    file-or-backup))

(defun vc-backup-list-backups (file-or-list)
  "Generate a list of all backups for FILE-OR-LIST.
FILE-OR-LIST can either be a string or a list of strings.  This
function returns all backups for these files, in order of their
recency."
  (let (versions)
    (dolist (file (if (listp file-or-list) file-or-list (list file-or-list)))
      (let ((filename (thread-last (vc-backup-get-read file)
			expand-file-name
			make-backup-file-name
			file-name-sans-versions)))
	(push (directory-files (file-name-directory filename) t
			       (concat (regexp-quote (file-name-nondirectory filename))
				       file-name-version-regexp "\\'")
			       t)
	      versions)))
    (sort (apply #'nconc versions) #'file-newer-than-file-p)))

(defun vc-backup-extract-version (file-or-backup)
  "Return a revision string for FILE-OR-BACKUP.
If FILE-OR-BACKUP is the actual file, \"real\" is
returned.  Otherwise, it returns the version number as a string or
\"prev\" for unversioned backups."
  (cond ((not (backup-file-name-p file-or-backup)) vc-backup-current-tag)
	((string-match "\\.~\\([[:digit:]]+\\)~\\'" file-or-backup)
	 (match-string 1 file-or-backup))
	(t vc-backup-previous-tag)))

(defun vc-backup-list-backup-versions (file)
  "Return an association list of backup files and versions for FILE.
Each element of the list has the form (VERS . BACKUP), where VERS
is the version string as generated by `vc-backup-extract-version'
and BACKUP is the actual backup file."
  (let (files)
    (dolist (backup (vc-backup-list-backups file))
      (push (cons (vc-backup-extract-version backup) backup)
	    files))
    files))

(defun vc-backup-get-backup-file (file rev)
  "Return backup file for FILE of the version REV."
  (cond ((string= rev vc-backup-current-tag) file)
	((string= rev vc-backup-previous-tag)
	 (let ((prev (thread-last (expand-file-name file)
		       make-backup-file-name
		       file-name-sans-versions
		       (format "%~"))))
	   (and (file-exists-p prev) prev)))
	((cdr (assoc rev (vc-backup-list-backup-versions file))))))

(defun vc-backup-last-rev (file)
  "Return the revision of the last backup for FILE."
  (thread-last (vc-backup-list-backups file)
    car
    vc-backup-extract-version))



(defun vc-backup-revision-granularity ()
  "Inform VC that this backend only operates on singular files."
  'file)

;;;###autoload
(defun vc-backup-registered (file)
  "Inform VC that FILE will work if a backup can be found."
  (or (not (null (diff-latest-backup-file file)))
      (backup-file-name-p file)))

(defun vc-backup-working-revision (file)
  "Check if FILE is the real file or a backup."
  (vc-backup-extract-version file))

(defun vc-backup-checkout-model (_files)
  "Inform VC that files are not locked."
  'implicit)

(defun vc-backup-state (_file)
  "Inform VC that there is no information about any file."
  nil)

;;;###autoload
(defun vc-backup-responsible-p (file)
  "Inform VC that this backend requires a backup for FILE."
  (not (null (diff-latest-backup-file file))))

(defun vc-backup-find-revision (file rev buffer)
  "Open a backup of the version REV for FILE in BUFFER."
  (with-current-buffer buffer
    (insert-file-contents (vc-backup-get-backup-file file rev))))

(defun vc-backup-checkout (file &optional rev)
  "Before copying an old version of FILE, force a backup.
If REV is non-nil, checkout that version."
  (cl-assert (= (length file) 1))
  (let ((backup-inhibited nil)
	(make-backup-files t))
    (with-current-buffer (find-file-noselect file)
      (backup-buffer)))
  (copy-file (vc-backup-get-backup-file file rev)
	     file t))

(defun vc-backup-find-admin-dir (file)
  "Inform VC that the FILE's backup directory is the administrative directory."
  (file-name-directory (diff-latest-backup-file file)))

(defun vc-backup-print-log (file buffer &optional _shortlog _start-revision _limit)
  "Generate a listing of old backup versions for FILE.
The results are written into BUFFER."
  (setq file (if (listp file) (car file) file))
  (with-current-buffer buffer
    (let ((inhibit-read-only t))
      (erase-buffer)
      (insert "Backups for " file "\n\n")
      (dolist (rev (nreverse (vc-backup-list-backup-versions file)))
	(let* ((attr (file-attributes (cdr rev)))
	       (stime (file-attribute-status-change-time attr))
	       (sdate (format-time-string "%c" stime)))
	  (insert (format "v%s\tFrom %s\n" (car rev) sdate)))))
    (goto-char (point-min))
    (forward-line 2))
  'limit-unsupported)

(define-derived-mode vc-backup-log-view-mode log-view-mode "Backup Log"
  "VC-Log Mode for Backup."
  (setq-local log-view-file-re "\\`Backups for \\(.+\\)$")
  (setq-local log-view-message-re "^v\\([[:alnum:]]+\\)"))

(defun vc-backup-diff (files &optional rev1 rev2 buffer async)
  "Generate a diff for FILES between versions REV1 and REV2.
BUFFER and ASYNC as interpreted as specified in vc.el."
  (cl-assert (= (length files) 1))
  (setq rev2 (or rev2 (vc-backup-last-rev files)))
  (save-window-excursion
    (let ((dirty nil))
      (dolist (file files)
	(let ((diff (diff-no-select
		     (vc-backup-get-backup-file file rev2)
		     (vc-backup-get-backup-file
		      file (or rev1 vc-backup-current-tag))
		     (vc-switches 'Backup 'diff)
		     (not async)
		     (get-buffer (or buffer "*vc-diff*")))))
	  (unless async
	    (with-current-buffer diff
	      (unless (search-forward "no differences" nil t)
		(setq dirty t))))))
      (if dirty 1 0))))

(defun vc-backup-revision-completion-table (files)
  "Return a list of revisions for FILES."
  (cl-assert (= (length files) 1))
  (mapcar #'car (vc-backup-list-backup-versions (car files))))

(defun vc-backup-make-version-backups-p (_file)
  "Always allow backup files to be made for this backend."
  t)

(defun vc-backup-previous-revision (file rev)
  "Determine the revision before REV for FILE."
  (let* ((backups (vc-backup-list-backups file))
	 (index (cl-position rev backups :key #'car)))
    (cond ((string= rev vc-backup-current-tag) (car backups))
	  ((string= rev vc-backup-previous-tag) nil)
	  ((and (natnump index) (> index 0))
	   (car (nth (1- index) backups))))))

(defun vc-backup-next-revision (file rev)
  "Determine the revision after REV for FILE."
  (let* ((backups (vc-backup-list-backups file))
	 (index (cl-position rev backups :key #'car)))
    (cond ((string= rev vc-backup-current-tag) nil)
	  ((and (natnump index) (< index (length backups)))
	   (car (nth (1+ index) backups)))
	  (t vc-backup-current-tag))))

(defun vc-backup-delete-file (file)
  "Delete FILE and all its backups."
  (dolist (backup (vc-backup-list-backups file))
    (delete-file backup))
  (delete-file file))

(defun vc-backup-rename-file (old-file new-file)
  "Rename OLD-FILE to NEW-FILE and all its backup accordingly."
  (rename-file old-file new-file)
  (let ((new-part (thread-last (expand-file-name new-file)
		    make-backup-file-name
		    file-name-sans-versions))
	(old-part (thread-last (expand-file-name old-file)
		    make-backup-file-name
		    file-name-sans-versions)))
    (dolist (backup (vc-backup-list-backups old-file))
      (let ((new-backup (concat new-part (substring backup (length old-part)))))
	(rename-file backup new-backup t)))))

(provide 'vc-backup)
;;; vc-backup.el ends here
