From 552dfc187707185940cb11c31e66e47ca3efacca Mon Sep 17 00:00:00 2001
From: Piotr Szarmanski
Date: Thu, 3 Aug 2023 00:31:49 +0200
Subject: Init.
---
src/backup.lisp | 210 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/cli.lisp | 135 +++++++++++++++++++++++++++++++++++
src/index.lisp | 137 ++++++++++++++++++++++++++++++++++++
src/package.lisp | 22 ++++++
4 files changed, 504 insertions(+)
create mode 100644 src/backup.lisp
create mode 100644 src/cli.lisp
create mode 100644 src/index.lisp
create mode 100644 src/package.lisp
(limited to 'src')
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 .
+
+;; 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 .
+
+;; 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 .
+
+(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)
--
cgit v1.2.3