From 552dfc187707185940cb11c31e66e47ca3efacca Mon Sep 17 00:00:00 2001
From: Piotr Szarmanski
Date: Thu, 3 Aug 2023 00:31:49 +0200
Subject: Init.

---
 README             |  28 +++++++
 src/backup.lisp    | 210 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/cli.lisp       | 135 ++++++++++++++++++++++++++++++++++
 src/index.lisp     | 137 ++++++++++++++++++++++++++++++++++
 src/package.lisp   |  22 ++++++
 tests/package.lisp |   6 ++
 ybackup.asd        |  24 ++++++
 7 files changed, 562 insertions(+)
 create mode 100644 README
 create mode 100644 src/backup.lisp
 create mode 100644 src/cli.lisp
 create mode 100644 src/index.lisp
 create mode 100644 src/package.lisp
 create mode 100644 tests/package.lisp
 create mode 100644 ybackup.asd

diff --git a/README b/README
new file mode 100644
index 0000000..4e2a626
--- /dev/null
+++ b/README
@@ -0,0 +1,28 @@
+ybackup is an ERIS (http://eris.codeberg.page/)-based backup/archive system. It
+takes a directory as an input, and packs all files in that hierarchy into ERIS
+data. Each file receives an individual URN, which is recorded along the file
+permissions, mtime and the filename in an index. The index reproduces the
+file-hierarchy, by representing directories, files and symlinks as objects.
+
+Features:
+
++ Thanks to ERIS, the data is automatically deduplicated. 
+
++ Convergent encryption by default (i.e. the files are encrypted based on their content)
+
++ An additional secret can be used for encryption to protect against attacks on convergent encryption.
+
++ Backups are specified by URNs and so are specific files within them, meaning
+that you could e.g. share a file with anyone without much effort.
+
++ It's transport and storage agnostic and could work on any medium permitting read/write access to 1/32kb blocks of binary data.
+
++ Incremental backups.
+
+Anti-features:
+
++ Backups cannot be trivially removed, which means that storage space
+consumption will increase as more backups are made;
+
+
+
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))))
diff --git a/src/cli.lisp b/src/cli.lisp
new file mode 100644
index 0000000..2f03425
--- /dev/null
+++ b/src/cli.lisp
@@ -0,0 +1,135 @@
+(in-package :ybackup)
+
+#|
+(defun fetch-configuration ()
+  (let ((xdg (uiop:getenv "XDG_CONFIG_DIR")))
+    (if xdg
+        (setf xdg (concatenate 'string xdg "/ybackup.lisp"))
+        (setf xdg (concatenate 'string (uiop:getenv "HOME") "/.config/ybackup.lisp")))
+    (ensure-directories-exist xdg)
+    (with-open-file (file xdg :if-does-not-exist :create)
+      (uiop:with-safe-io-syntax
+          (uiop:slurp-stream-form :at nil)))))
+|#
+(opts:define-opts
+  (:name :help
+   :description "Print this text"
+   :short #\h
+   :long "help")
+  (:name :backup
+   :description "Directory to backup"
+   :short #\b
+   :long "backup"
+   :arg-parser #'identity
+   :meta-var "DIRECTORY")
+  (:name :read
+   :description "Read a backup to a directory"
+   :short #\r
+   :long "read"
+   :arg-parser #'identity
+   :meta-var "DIRECTORY")
+  (:name :list-files
+   :description "List the files in the repository."
+   :short #\l
+   :long "list")
+  (:name :file-backend
+   :description
+   "Use this for a file-based local backup. The argument is the directory that will
+contain the ERIS chunks."
+   :long "file-backend"
+   :arg-parser #'identity
+   :meta-var "DIRECTORY")
+  (:name :http-backend
+   :description
+   "Use this for an HTTP-based backup. The argument is the URL which will accept
+the ERIS chunks."
+   :long "http"
+   :arg-parser #'identity
+   :meta-var "URL")
+  (:name :backend
+   :description "An S-expression that returns a valid eris:backend object."
+   :long "backend"
+   :meta-var "SEXP"
+   :arg-parser #'read-from-string)
+  (:name :filter
+   :description
+   "A one-argument lambda S-expression that takes a filename as an argument and
+returns nil if the file is to be read or t if it is to be skipped."
+   :long "filter"
+   :meta-var "SEXP"
+   :arg-parser #'read-from-string)
+  (:name :overwrite
+   :description "Set if the program should overwrite existing files when writing from backup. "
+   :long "overwrite")
+  (:name :incremental
+   :description "Set to enable incremental backup. Requires the --repo optio.."
+   :short #\i
+   :long "incremental")
+  (:name :repo
+   :description "The file that the URN will be written or read from."
+   :long "repo"
+   :meta-var "FILE OR URN"
+   :arg-parser #'identity)
+  (:name :secret
+   :description "The secret used for encryption."
+   :long "secret"
+   :short #\s
+   :meta-var "SECRET"
+   :arg-parser #'identity)
+  (:name :metadata
+   :description "Print repository metadata when reading or listing files."
+   :long "metadata"
+   :short #\m))
+
+(defun file-or-urn-to-urn (file-or-urn)
+  (if (string-prefix-p "urn:" file-or-urn)
+      file-or-urn
+      (with-open-file (file file-or-urn :direction :input :if-does-not-exist :error)
+        (read-line file))))
+
+(defun main ()
+  (restart-case (destructuring-bind (&key help backup read list-files
+                                       file-backend http-backend backend
+                                       filter overwrite incremental repo
+                                       secret metadata)
+                    (opts:get-opts)
+                  ;; some sanity checks
+                  ;; exclusive options
+                  (when (or (and backup read) (and backup list-files) (and read list-files))
+                    (error "Choose one of read, backup, or list."))
+                  (when (or (and backend http-backend) (and backend file-backend) (and file-backend http-backend))
+                    (error "Choose one backend."))
+
+                  (when help
+                    (opts:describe :prefix #.(format nil "ybackup version ~a" version))
+                    (opts:exit))
+
+                  ;; repo argument necessary except for backup
+                  #|(when (and (not repo) backup)
+                    (error "Please provide --repo argument."))|#
+
+                  ;; don't save urns to files named urn:
+                  #|(when (and backup repo (string-prefix-p "urn:" repo))
+                    (error "No urns as filenames."))|#
+
+                  (let ((backend
+                          (cond
+                            (file-backend (make-instance 'eris:file-backend :directory file-backend))
+                            (http-backend (error "Unimplemented http-backend."))
+                            (backend (eval backend))
+                            (t (error "Choose backend.")))))
+                    ;; TODO:
+                    ;; ADD METADATA, SECRET HANDLING (!!!)
+                    
+                    (cond
+                      (list-files
+                       (print (list-files (file-or-urn-to-urn repo) backend))
+                       ())
+                      (backup (let ((urn (make-backup backup backend :incremental incremental)))
+                                (if repo (with-open-file (file repo :direction :output :if-does-not-exist :create
+                                                               :if-exists :new-version)
+                                           (write-string urn file))
+                                    (princ urn))))
+                      (read (read-backup (file-or-urn-to-urn repo) backend read :overwrite overwrite)))
+                    (opts:exit)))
+    (exit () (opts:exit))))
diff --git a/src/index.lisp b/src/index.lisp
new file mode 100644
index 0000000..c3fea65
--- /dev/null
+++ b/src/index.lisp
@@ -0,0 +1,137 @@
+;; 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 code related to the repository format and indices.
+
+(in-package :ybackup)
+
+(defclass base-file ()
+  ((permissions :initarg :permissions :type (unsigned-byte 16))
+   (name :initarg :name :type string)))
+
+(defclass file (base-file)
+  ((read-capability :initarg :read-capability :type (simple-array (unsigned-byte 8) (66)))
+   (date :initarg :date :type (unsigned-byte 64)
+         :documentation "Modification time of the file.")))
+
+(defclass dir (base-file)
+  ((files :initarg :files :type hash-table)))
+
+(defclass symlink (base-file)
+  ((link :initarg :link :type string)))
+
+(defclass previous-repository ()
+  ((date :initarg :date :type (unsigned-byte 64))
+   (read-capability :initarg :read-capability :type (octet-vector 66))
+   (name :initarg :name :type string)))
+
+(defclass repository ()
+  ((files :initarg :files :type dir)
+   (date :initarg :date :type (unsigned-byte 64))
+   (name :initarg :name :type string)
+   (previous-repository :initarg :previous-repository :type (or null (octet-vector 66)))))
+
+(conspack:defencoding file
+  permissions name read-capability date)
+
+(conspack:defencoding dir
+  permissions name files)
+
+(conspack:defencoding symlink
+ permissions name link)
+
+(conspack:defencoding previous-repository
+  date read-capability name)
+
+(conspack:defencoding repository
+  files date name previous-repository)
+
+(conspack:define-index backup-index
+  name permissions read-capability date files link file dir symlink repository previous-repository)
+
+(alexandria:define-constant permission-flags
+    '((:user-read 1)
+      (:user-write 2)
+      (:user-exec 3)
+      (:group-read 4)
+      (:group-write 5)
+      (:group-exec 6)
+      (:other-read 7)
+      (:other-write 8)
+      (:other-exec 9)
+      (:set-user-id 10)
+      (:set-group-id 11)
+      (:sticky 12)
+      (t 13))
+  :test #'equalp)
+
+
+(-> osicat-file-permissions-to-integer (list) (values (unsigned-byte 16) &optional))
+(-> integer-to-file-permissions ((unsigned-byte 16)) (values list &optional))
+
+(defun osicat-file-permissions-to-integer (permissions)
+  "Convert a list of file permissions as returned by osicat:file-permissions to a
+16-bit integer, represented as a set of bit flags."
+  (let ((flags (make-array 16 :element-type 'bit :initial-element 0)))
+    (declare (type (simple-bit-vector 16) flags)
+             (dynamic-extent flags))
+    (map nil (lambda (perm)
+               #.`(ecase perm
+                    ,@(map 'list (lambda (pair) `(,(first pair) (setf (sbit flags ,(second pair)) 1)))
+                       permission-flags)))
+         permissions)
+    ;; always set the MSB and LSB so that the integer is always 16-bit
+    (setf (sbit flags 15) 1
+          (sbit flags 0) 1) 
+    (bit-smasher:bits->int flags)))
+
+(defun integer-to-file-permissions (integer)
+  (let ((flags (bit-smasher:int->bits integer)))
+    (declare (type bit-vector flags)
+             (dynamic-extent flags))
+    (declare (type (simple-bit-vector 16) flags))
+    (loop for i from 1 to 14
+          if (eq 1 (sbit flags i))
+            collecting (cdr
+                        (assoc i '#.(loop for (x y) in permission-flags
+                                          collecting (cons y x)))))))
+
+(defgeneric print-file (file)
+  (:documentation "Return the file object as a S-expression."))
+
+(defmethod print-file ((file file))
+  (with-slots (permissions name read-capability date) file
+    (list :file name
+          (eris:read-capability-to-urn (eris:octets-to-read-capability read-capability))
+          (local-time:format-timestring nil (local-time:universal-to-timestamp date))
+          permissions)))
+
+(defmethod print-file ((file symlink))
+  (with-slots (permissions name link) file
+    (list :symlink name :to link)))
+
+(defmethod print-file ((file dir))
+  (with-slots (permissions name files) file
+    (list :directory name :files (loop for key being the hash-key using (hash-value file) of files
+                                     collect (print-file file)))))
+
+(defun print-repository (repo)
+  (with-slots (files date name previous-repository) repo
+    (list :name name :date (local-time:format-timestring nil (local-time:universal-to-timestamp date))
+          :files files
+          :previous-repository (if previous-repository
+                                   (eris:read-capability-to-urn
+                                    (eris:octets-to-read-capability previous-repository))
+                                   nil))))
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..e6885e8
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,22 @@
+;; 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/>.
+
+(defpackage :ybackup
+  (:use #:common-lisp #:eris #:serapeum)
+  (:export #:main #:read-backup #:make-backup #:list-files))
+
+(in-package :ybackup)
+
+(alexandria:define-constant version '(0 1) :test #'equalp)
diff --git a/tests/package.lisp b/tests/package.lisp
new file mode 100644
index 0000000..8183edf
--- /dev/null
+++ b/tests/package.lisp
@@ -0,0 +1,6 @@
+(defpackage :ybackup/test
+  (:use common-lisp fiveam))
+
+(in-package :ybackup/test)
+(def-suite ybackup-tests
+  :description "Root test suite for ybackup.")
diff --git a/ybackup.asd b/ybackup.asd
new file mode 100644
index 0000000..529c0a1
--- /dev/null
+++ b/ybackup.asd
@@ -0,0 +1,24 @@
+(defsystem "ybackup"
+  :author "mail@ykonai.net"
+  :license "LGPLv3 or later"
+  :depends-on ("eris" "serapeum" "alexandria" "cl-conspack" "osicat" "unix-opts" "bit-smasher" "local-time")
+  :components
+  ((:module "src"
+    :serial t
+    :components ((:file "package")
+                 (:file "index")
+                 (:file "backup")
+                 (:file "cli"))))
+  :in-order-to ((test-op (test-op :ybackup/test))))
+
+(defsystem "ybackup/test"
+  :name "ybackup/test":depends-on ("ybackup" "fiveam")
+  :perform (test-op (op c)
+                    (symbol-call :fiveam :run! (find-symbol* :ybackup-tests :ybackup/test)))
+  :components
+  ((:module "tests"
+    :serial t
+    :components ((:file "package"))))
+
+  :entry-point "ybackup:main"
+  :build-pathname "ybackup")
-- 
cgit v1.2.3