diff options
Diffstat (limited to 'src/backup.lisp')
| -rw-r--r-- | src/backup.lisp | 210 |
1 files changed, 210 insertions, 0 deletions
diff --git a/src/backup.lisp b/src/backup.lisp new file mode 100644 index 0000000..82de46e --- /dev/null +++ b/src/backup.lisp @@ -0,0 +1,210 @@ +;; This file is part of ybackup. +;; Copyright (C) 2022 Piotr Szarmański + +;; ybackup is free software: you can redistribute it and/or modify it under the +;; terms of the GNU Lesser General Public License as published by the Free +;; Software Foundation, either version 3 of the License, or (at your option) any +;; later version. + +;; ybackup 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 +;; ybackup. If not, see <https://www.gnu.org/licenses/>. + +;; This file contains the code related to uploading and reading backups. The +;; make-backup, read-backup and list-files functions are the most important. + +(in-package :ybackup) + +(defun filename-last-part (filename) + (let* ((name (namestring filename)) + (end (1- (length name)))) + (loop while (eql #\/ (aref name end)) + do (decf end)) + (subseq name + (or (loop for i from end downto 0 + when (eql #\/ (aref name i)) + return (1+ i)) + 0) + (1+ end)))) + +(defvar *eris-secret* eris:null-secret) +(defvar *eris-backend* nil) + +(defun package-file (target-file &key incremental-record file-predicate) + (declare (ignore file-predicate)) + (ecase (osicat:file-kind target-file :follow-symlinks nil) + (:regular-file + ;; if incremental-record is set and the mtime matches, then ignore it + (if (and incremental-record + (eql (file-write-date target-file) (slot-value incremental-record 'date))) + incremental-record + (let ((read-capability + (eris:read-capability-to-octets + (with-open-file (file target-file :direction :input :element-type 'octet) + (eris:store-data file *eris-backend* :secret *eris-secret*))))) + (declare (type (octet-vector 66) read-capability)) + (make-instance 'file + :date (file-write-date target-file) + :name (filename-last-part target-file) + :permissions (osicat-file-permissions-to-integer (osicat:file-permissions target-file)) + :read-capability read-capability)))) + (:symbolic-link + (if (and incremental-record (eql (file-write-date target-file) (slot-value incremental-record 'date))) + incremental-record + (make-instance + 'symlink + :link (namestring (osicat:read-link target-file)) + :name (filename-last-part target-file) + ;; osicat:file-permissions cannot be used here because it resolves symlinks. Set it to 0 instead. + :permissions 0))) + (:directory + ;; Do not check incremental records here. + (make-instance + 'dir + :permissions (osicat-file-permissions-to-integer (osicat:file-permissions target-file)) + :name (filename-last-part target-file) + :files (let* ((files (uiop:directory* + (make-pathname :directory (namestring target-file) + :name :wild :type :wild :version :wild))) + (table (make-hash-table :size (+ 7 (length files)) :test #'equal))) + (map nil #'(lambda (file) + ;; Handle files that aren't in the ecase + (handler-case + (setf (serapeum:href table (filename-last-part file)) + (package-file + file + :incremental-record + (if incremental-record + (serapeum:href (slot-value incremental-record 'files) + (filename-last-part file)) + nil))) + (type-error () (format t "Warning: file ~a of type ~a ignored." file (osicat:file-kind file :follow-symlinks nil))))) + files) + table))))) + +(defun make-backup (directory backend + &key incremental + (secret eris:null-secret) + (name (local-time:format-rfc3339-timestring nil (local-time:now)))) + "Make a backup of DIRECTORY into BACKEND. + +If INCREMENTAL is a URN, then incrementally backup using that repository. +Otherwise, create a new repository. + +SECRET can be specified in order to use a specific secret for ERIS encryption. +This secret is only necessary when writing. If an incremental backup is done, +the secret used is always the same as in the original repository." + + (declare (type string incremental name) + (type octet-vector secret) + (type (or pathname string) directory)) + ;; check for existance of directory + ;; TODO: actual condition + (unless (uiop:directory-exists-p directory) + (error 'error)) + (let ((*eris-backend* backend) + (*eris-secret* secret)) + + ;; fetch incremental index + (let ((incremental-index (when incremental (fetch-index incremental)))) + (eris:read-capability-to-urn + (eris:store-data + (cpk:with-named-index 'backup-index + (cpk:encode + (make-instance 'repository + :files (package-file directory + :incremental-record + (if incremental + (slot-value incremental-index 'files) + nil)) + :date (get-universal-time) + :name name + :previous-repository + (eris:read-capability-to-octets (eris:urn-to-read-capability incremental))))) + *eris-backend* + :secret *eris-secret*))))) + + +;;; BACKUP READING + +(defun fetch-index (urn) + (cpk:with-named-index 'backup-index + (cpk:decode + (alexandria:read-stream-content-into-byte-vector + (eris:fetch-data (eris:urn-to-read-capability urn) *eris-backend*))))) + +(defgeneric unpack-file (file directory &key overwrite)) + +(defmethod unpack-file ((file file) directory &key overwrite) + (with-slots (read-capability name permissions) file + (let ((filename (merge-pathnames directory name))) + (with-open-file (stream filename + :direction :output + :if-does-not-exist :create + :if-exists (if overwrite :supersede :error) + :element-type 'octet) + (alexandria:copy-stream + (eris:fetch-data (eris:octets-to-read-capability read-capability) *eris-backend*) + stream)) + (setf (osicat:file-permissions filename) + (integer-to-file-permissions permissions))))) + +(defmethod unpack-file ((symlink symlink) directory &key overwrite) + (with-slots (name link) symlink + (when (and (osicat:file-exists-p (merge-pathnames directory name)) (not overwrite) + ;; TODO: actual error + (error 'error))) + (osicat:make-link (merge-pathnames directory name) + :target link))) + +(defmethod unpack-file ((dir dir) directory &key overwrite) + (with-slots (name permissions files) dir + (let ((next-dir (make-pathname :directory (append1 (pathname-directory directory) name) + :defaults directory))) + (ensure-directories-exist next-dir) + (setf (osicat:file-permissions next-dir) (integer-to-file-permissions permissions)) + (maphash #'(lambda (key value) + (declare (ignore key)) + (unpack-file value next-dir :overwrite overwrite)) + files)))) + +(defun read-backup (urn backend target-directory &key (overwrite nil)) + "Read/unpack the backup into TARGET-DIRECTORY. + +OVERWRITE keyword decides whether to overwrite files. By default, it errors on +encountering existing files. Set to T to overwrite existing files. + +TODO: Add an option to make it just ignore existing files." + (let ((*eris-backend* backend)) + (when (null (pathname-directory target-directory)) + (error 'error)) + (unpack-file (slot-value (fetch-index urn) 'files) target-directory :overwrite overwrite))) + +(defun read-specific-file (urn backend target-directory specific-file) + "Read a specific file from a backend. The file is given as a list containing the +successive directories and the file-name at the end, such as `(\"home\" \"user\" +\"images\" \"dog.png\")'. This does not respect symlinks whatsoever." + (let* ((*eris-backend* backend) + (index-files (slot-value (fetch-index urn) 'files))) + (unless (equal (first specific-file) (slot-value index-files 'name)) + (error 'cl:file-error :pathname specific-file)) + (unpack-file + (loop for i from 0 to (length specific-file) + for file = index-files + then (gethash (nth i specific-file) (slot-value file 'files)) + when (null file) + do (error 'cl:file-error :pathname specific-file) + if (null (nth (1+ i) specific-file)) + return file) + target-directory))) + +(defun list-files (urn backend) + (let ((*eris-backend* backend)) + (print-file (slot-value (fetch-index urn) 'files)))) + +(defun metadata (urn backend) + (let ((*eris-backend* backend)) + (print-repository (fetch-index urn)))) |