source: project/release/4/ugarit/trunk/ugarit.scm @ 15242

Last change on this file since 15242 was 15242, checked in by Alaric Snell-Pym, 11 years ago

C-Keen's patches

File size: 11.7 KB
Line 
1(use ugarit-core)
2
3(use srfi-37)
4(use miscmacros)
5(use matchable)
6(use regex)
7
8(define (bit? i b)
9   (not (zero? (bitwise-and i b))))
10
11(define (print-posix-mode mode)
12   (if (bit? mode perm/irusr) (printf "r") (printf "-"))
13   (if (bit? mode perm/iwusr) (printf "w") (printf "-"))
14   (if (bit? mode perm/ixusr) (printf "x") (printf "-"))
15   (if (bit? mode perm/irgrp) (printf "r") (printf "-"))
16   (if (bit? mode perm/iwgrp) (printf "w") (printf "-"))
17   (if (bit? mode perm/ixgrp) (printf "x") (printf "-"))
18   (if (bit? mode perm/iroth) (printf "r") (printf "-"))
19   (if (bit? mode perm/iwoth) (printf "w") (printf "-"))
20   (if (bit? mode perm/ixoth) (printf "x") (printf "-")))
21
22(define (print-long-dirent name type props)
23   (case type
24      ((file) (printf "-"))
25      ((dir) (printf "d"))
26      ((symlink) (printf "l"))
27      ((fifo) (printf "p"))
28      ((block-device) (printf "b"))
29      ((character-device) (printf "c"))
30      ((tag) (printf "t"))
31      ((snapshot) (printf "s"))
32      (else (printf "?")))
33   
34   (if (assq 'mode props)
35      (print-posix-mode (cdr (assq 'mode props)))
36      (printf "........."))
37   
38   (if (assq 'uid props) ; FIXME: pad to fixed width
39      (printf " ~A" (cdr (assq 'uid props)))
40      (printf " -"))
41
42   (if (assq 'gid props) ; FIXME: pad to fixed width
43      (printf " ~A" (cdr (assq 'gid props)))
44      (printf " -"))
45   
46   (if (assq 'mtime props)
47      (printf " ~A" (epochtime->string (cdr (assq 'mtime props))))
48      (printf " -"))
49   
50   (if (and (eq? type 'symlink) (assq 'target props))
51      (printf " ~A -> ~A\n" name (cdr (assq 'target props)))
52      (printf " ~A\n" name)))
53   
54;; To get started, call (ls-archive archive '() long-format #f)
55;; long-format is #f to just list names and types,
56;; 'very to list EVERYTHING,
57;; or #t to list long lines.
58(define (ls-archive archive directory-key long-format match-re)
59   (let ((*row* 0))
60      (let/cc escape
61         (fold-archive-node archive directory-key
62            (lambda (node-key dirent acc)
63               (let ((name (car dirent)))
64                  (if (or (not match-re) (string-match match-re name))
65                     (begin
66                        (if (> *row* 20)
67                           (begin
68                              (printf "-- Press q then enter to stop or enter for more...\n")
69                              (set! *row* 0)
70                              (if (string=? (read-line) "q")
71                                 (escape (void)))))
72                        (inc! *row*)
73                        (let ((type (cadr dirent))
74                              (props (cddr dirent)))
75               
76                           (if long-format
77                              (begin
78                                 ; Print standard long line
79                                 (print-long-dirent name type props)
80                     
81                                 (if (eq? long-format 'very)
82                                    (begin
83                                       (for-each
84                                          (lambda (prop) 
85                                             (case (car prop)
86                                                ((mode) (void))
87                                                ((uid) (void))
88                                                ((gid) (void))
89                                                ((mtime) (void))
90                                             (else (printf "~A: ~A\n" (car prop) (cdr prop)))))
91                                          props)))))
92                           (if (not long-format)
93                              (printf "~A <~A>\n" name type))))
94               
95                        (void))))
96                     (void)))))
97
98(define (extract-file-from-node! archive directory-key name path success-continuation)
99   (fold-archive-node archive directory-key
100      (lambda (node-key dirent acc)
101         (if (string=? (car dirent) name)
102            (case (cadr dirent)
103               ((tag) (begin
104                  (printf "You can't extract an entire tag - choose an actual snapshot at least\n")
105                  (success-continuation)))
106               ((snapshot)
107                  (begin
108                     (define name (car path)) ; Head of path is the tag name - the best name we have available
109                     (if (not (directory? name))
110                        (create-directory name))
111
112                     (extract-directory! archive
113                        (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot
114                        name)
115                     (printf "Extracted ~A\n" name)
116                     (success-continuation)))
117               (else
118                  (begin
119                     (extract-object! archive dirent ".")
120                     (printf "Extracted ~A\n" name)
121                     (success-continuation))))
122           acc))
123     #f))
124
125;; To get started, call with '() as directory-key and path
126(define (explore-archive archive directory-key path quit-continuation)
127   (printf "~A> " (apply string-append (map (lambda (element) (string-append "/" element)) path)))
128   (let ((line (read-line)))
129      (if (eq? line #!eof)
130         (quit-continuation (void)))
131     
132      (let ((result (string-split line)))
133 
134         (match result
135            (("")
136               (explore-archive archive directory-key path quit-continuation))
137            (("help")
138               (printf "cd .. : Go up one level\n")
139               (printf "quit : leave Ugarit\n")
140               (printf "ls [<pattern>] : list objects in the current directory\n")
141               (printf "ls -l [<pattern>] : list objects and their core metadata\n")
142               (printf "ls -ll [<pattern>] : list objects with a full list of metadata\n")
143               (printf "cd <dir/tag/snapshot> : Go into a directory, tag, or snapshot\n")
144               (printf "get <dir/file/object> : Extract something from the archive\n")
145               (explore-archive archive directory-key path quit-continuation))
146     
147            (("cd" "..")
148               (void)) ; Go up one level
149            ((or ("bye") ("quit") ("exit"))
150               (quit-continuation (void)))
151            (("ls" "-l" . globparts)
152               (if (null? globparts)
153                  (ls-archive archive directory-key #t #f)
154                  (ls-archive archive directory-key #t (glob->regexp (string-join globparts))))
155               (explore-archive archive directory-key path quit-continuation))
156            (("ls" "-ll" . globparts)
157               (if (null? globparts)
158                  (ls-archive archive directory-key 'very #f)
159                  (ls-archive archive directory-key 'very (glob->regexp (string-join globparts))))
160               (explore-archive archive directory-key path quit-continuation))
161            (("ls" . globparts)
162               (if (null? globparts)
163                  (ls-archive archive directory-key #f #f)
164                  (ls-archive archive directory-key #f (glob->regexp (string-join globparts))))
165               (explore-archive archive directory-key path quit-continuation))
166            (("cd" . dirparts)
167               (let* ((dir (string-join dirparts))
168                      (new-level
169                         (fold-archive-node archive directory-key
170                            (lambda (node-key dirent acc)
171                               (if (string=? (car dirent) dir)
172                                  node-key
173                                  acc))
174                            #f)))
175                  (if new-level
176                     (explore-archive archive new-level (reverse (cons dir (reverse path))) quit-continuation)
177                     (printf "No such subdirectory ~A\n" dir))
178                  (explore-archive archive directory-key path quit-continuation)))
179            (("get" . nameparts)
180               (let* ((name (string-join nameparts))
181                      (success (extract-file-from-node! archive directory-key name path
182                         (lambda ()
183                            (explore-archive archive directory-key path quit-continuation)))))
184               
185                  (printf "No such file or directory ~A\n" name)
186
187                  (explore-archive archive directory-key path quit-continuation)))
188            (else
189               (printf "Unknown command ~A\n" result)
190               (explore-archive archive directory-key path quit-continuation))))))
191
192;;
193;; MAIN FUNCTION
194;;
195
196(define *store-ctime?* #f)
197(define *store-atime?* #f)
198(define *snapshot-notes* '())
199
200(define help 
201  (option 
202   '(#\h "help") #f #f
203   (lambda _ 
204     (print "Usage:
205ugarit snapshot <path to ugarit.conf> [-c] [-a] [-n <notes>] <tag> <path to root of filesystem>
206   ...makes a snapshot of the given filesystem to the given tag in the archive identified by ugarit.conf
207   -c --store-ctime   Store inode change/creation times in the archive
208   -a --store-atime   Store file access times in the archive
209   -n <notes> --notes=<notes>  Store notes with the snapshot
210ugarit explore <path to ugarit.conf>
211   ...explores the archive, allowing interactive extraction
212ugarit fork <path to ugarit.conf> <tag> <new tag>
213   ...copies a tag, forking the history
214ugarit [-h|--help]
215   ...shows this text")
216     (exit) ) ) )
217
218(define store-ctime
219  (option
220   '(#\c "store-ctime") #f #f
221   (lambda (o n x vals)
222     (set! *store-ctime?* #t)
223     vals) ) )
224
225(define store-atime
226 (option
227  '(#\a "store-atime") #f #f
228  (lambda (o n x vals)
229    (set! *store-atime?* #t)
230    vals) ) )
231
232(define notes
233(option
234'(#\n "notes") #t #f
235(lambda (o n x vals)
236  (set! *snapshot-notes* (cons x *snapshot-notes*))
237  vals) ) )
238
239(define command-line
240   (reverse
241      (args-fold
242      (command-line-arguments)
243      (list help store-ctime store-atime notes)
244      (lambda (o n x vals)
245        (error "unrecognized option" n) )
246      cons
247      '())))
248
249
250; FIXME: Error checking. confpath exists, that sort of thing.
251(match command-line
252   (("snapshot" confpath tag fspath)
253      (let ((archive (open-archive
254         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
255         
256         (printf "Archiving ~A to tag ~A...\n" fspath tag)
257         (define-values (dir-key dir-reused?)
258            (store-directory! archive fspath))
259         (printf "Root hash: ~A\n" dir-key)
260         (let ((snapshot-key (tag-snapshot! archive tag dir-key dir-reused? (list
261               (cons 'hostname (get-host-name))
262               (cons 'source-path fspath)
263               (cons 'notes *snapshot-notes*)))))
264            (printf "Successfully archived ~A to tag ~A\n" fspath tag)
265            (printf "Snapshot hash: ~A\n" snapshot-key)
266            (archive-close! archive))))
267     
268   (("explore" confpath)
269      (let ((archive (open-archive
270         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
271
272         (let/cc quit
273            (explore-archive archive '() '() quit))
274         (archive-close! archive)))
275         
276   (("fork" confpath tag newtag)
277      (let ((archive (open-archive
278         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
279         
280         (archive-set-tag! archive newtag (archive-tag archive tag))
281         (printf "Copied tag ~A to ~A\n" tag newtag)
282         (archive-close! archive)))
283   
284   (("cat" confpath key)
285      (let ((archive (open-archive
286         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
287         (let ((type (archive-exists? archive key))
288               (block (archive-get archive key)))
289               (printf "BLock with key ~A (type ~A) is ~A bytes:\n" key type (u8vector-length block))
290               (write-u8vector block))
291           
292         (archive-close! archive)))
293   
294   (_
295      (printf "Invalid command line. Try \"ugarit -h\" for help.\n") (exit)))
296
297;; To explore the archive:
298;;         (let/cc quit
299;;            (explore-archive archive '() '() quit))
Note: See TracBrowser for help on using the repository browser.