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

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

ugarit: README updates, plus reporting on file cache performance.

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