1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
;; This file is part of ybackup.
;; Copyright (C) 2023 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 (append (uiop:directory-files (namestring target-file))
(uiop:subdirectories (namestring target-file))))
(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 (or null 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 (if incremental (fetch-index incremental) nil)))
(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
(if incremental
(eris:read-capability-to-octets (eris:urn-to-read-capability incremental))
nil))))
*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))
(let ((index (fetch-index urn)))
(print-file (slot-value index 'files)))))
(defun metadata (urn backend)
(let ((*eris-backend* backend))
(print-repository (fetch-index urn))))
(defun search-predicate (predicate urn backend)
"Return a list of files that return non-nil when applied to PREDICATE"
(let ((*eris-backend* backend))
(let ((index (fetch-index urn)))
(fmap-over-dir
(lambda (f) (if (funcall predicate f) f nil))
(slot-value index 'files)))))
(defun search-regexp (regexp urn backend)
"Return a list of files whose names match REGEXP."
(let ((scanner (ppcre:create-scanner regexp)))
(search-predicate (lambda (file) (ppcre:scan scanner (slot-value file 'name)))
urn backend)))
(defmacro collect-if (expr collector)
(alexandria:with-gensyms (v)
`(let ((,v ,expr))
(if ,v (,collector ,v)))))
(defun fmap-over-dir (fn dir)
"Apply FN to each file under DIR, excluding directories. A list of non-nil
return values of FN is returned.."
(mvlet ((lfiles ldirs
(with-collectors (cfiles cdirs)
(loop for i being the hash-value of (slot-value dir 'files)
do (typecase i
(dir (collect-if (fmap-over-dir fn i) cdirs)) ;; makes a list of lists
(t (collect-if (funcall fn i) cfiles)))))))
(apply #'concatenate 'list lfiles ldirs)))
|
