Init.

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))))