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

Last change on this file since 25521 was 25479, checked in by Alaric Snell-Pym, 10 years ago

ugarit: Dotting is, crossing ts...

File size: 12.8 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  (handle-exceptions exn
101                     (begin
102                       (printf "ERROR: Could not extract ~a: ~a in ~a\n"
103                               name
104                               ((condition-property-accessor 'exn 'message "Unknown error") exn)
105                               (cons ((condition-property-accessor 'exn 'location (void)) exn)
106                                     ((condition-property-accessor 'exn 'arguments (void)) exn)))
107                       (success-continuation))
108   (fold-archive-node archive directory-key
109                      (lambda (node-key dirent acc)
110                        (if (string=? (car dirent) name)
111                            (case (cadr dirent)
112                              ((tag) (begin
113                                       (printf "You can't extract an entire tag - choose an actual snapshot at least\n")
114                                       (success-continuation)))
115                              ((snapshot)
116                               (begin
117                                 (define name (car path)) ; Head of path is the tag name - the best name we have available
118                                 (if (not (directory? name))
119                                     (create-directory name))
120
121                                 (extract-directory! archive
122                                                     (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot
123                                                     name)
124                                 (printf "Extracted ~A\n" name)
125                                 (success-continuation)))
126                              (else
127                               (begin
128                                 (extract-object! archive dirent ".")
129                                 (printf "Extracted ~A\n" name)
130                                 (success-continuation))))
131                            acc))
132                      #f)))
133
134;; To get started, call with '() as directory-key and path
135(define (explore-archive archive directory-key path quit-continuation)
136   (printf "~A> " (apply string-append (map (lambda (element) (string-append "/" element)) path)))
137   (let ((line (read-line)))
138      (if (eq? line #!eof)
139         (quit-continuation (void)))
140     
141      (let ((result (string-split line)))
142 
143         (match result
144            (()
145               (explore-archive archive directory-key path quit-continuation))
146            (("help")
147               (printf "cd .. : Go up one level\n")
148               (printf "quit : leave Ugarit\n")
149               (printf "ls [<pattern>] : list objects in the current directory\n")
150               (printf "ls -l [<pattern>] : list objects and their core metadata\n")
151               (printf "ls -ll [<pattern>] : list objects with a full list of metadata\n")
152               (printf "cd <dir/tag/snapshot> : Go into a directory, tag, or snapshot\n")
153               (printf "get <dir/file/object> : Extract something from the archive\n")
154               (explore-archive archive directory-key path quit-continuation))
155     
156            (("cd" "..")
157               (void)) ; Go up one level
158            ((or ("bye") ("quit") ("exit"))
159               (quit-continuation (void)))
160            (("ls" "-l" . globparts)
161               (if (null? globparts)
162                  (ls-archive archive directory-key #t #f)
163                  (ls-archive archive directory-key #t (glob->regexp (string-join globparts))))
164               (explore-archive archive directory-key path quit-continuation))
165            (("ls" "-ll" . globparts)
166               (if (null? globparts)
167                  (ls-archive archive directory-key 'very #f)
168                  (ls-archive archive directory-key 'very (glob->regexp (string-join globparts))))
169               (explore-archive archive directory-key path quit-continuation))
170            (("ls" . globparts)
171               (if (null? globparts)
172                  (ls-archive archive directory-key #f #f)
173                  (ls-archive archive directory-key #f (glob->regexp (string-join globparts))))
174               (explore-archive archive directory-key path quit-continuation))
175            (("cd" . dirparts)
176               (let* ((dir (string-join dirparts))
177                      (new-level
178                         (fold-archive-node archive directory-key
179                            (lambda (node-key dirent acc)
180                               (if (string=? (car dirent) dir)
181                                  node-key
182                                  acc))
183                            #f)))
184                  (if new-level
185                     (explore-archive archive new-level (reverse (cons dir (reverse path))) quit-continuation)
186                     (printf "No such subdirectory ~A\n" dir))
187                  (explore-archive archive directory-key path quit-continuation)))
188            (("get" . nameparts)
189               (let* ((name (string-join nameparts))
190                      (success (extract-file-from-node! archive directory-key name path
191                         (lambda ()
192                            (explore-archive archive directory-key path quit-continuation)))))
193
194                  (printf "No such file or directory ~A\n" name)
195
196                  (explore-archive archive directory-key path quit-continuation)))
197            (else
198               (printf "Unknown command ~A\n" result)
199               (explore-archive archive directory-key path quit-continuation))))))
200
201;;
202;; MAIN FUNCTION
203;;
204
205(define *store-ctime?* #f)
206(define *store-atime?* #f)
207(define *snapshot-notes* '())
208
209(define help 
210  (option 
211   '(#\h "help") #f #f
212   (lambda _ 
213     (print "Usage:
214ugarit snapshot <path to ugarit.conf> [-c] [-a] [-n <notes>] <tag> <path to root of filesystem>
215   ...makes a snapshot of the given filesystem to the given tag in the archive identified by ugarit.conf
216   -c --store-ctime   Store inode change/creation times in the archive
217   -a --store-atime   Store file access times in the archive
218   -n <notes> --notes=<notes>  Store notes with the snapshot
219ugarit explore <path to ugarit.conf>
220   ...explores the archive, allowing interactive extraction
221ugarit fork <path to ugarit.conf> <tag> <new tag>
222   ...copies a tag, forking the history
223ugarit [-h|--help]
224   ...shows this text")
225     (exit) ) ) )
226
227(define store-ctime
228  (option
229   '(#\c "store-ctime") #f #f
230   (lambda (o n x vals)
231     (set! *store-ctime?* #t)
232     vals) ) )
233
234(define store-atime
235 (option
236  '(#\a "store-atime") #f #f
237  (lambda (o n x vals)
238    (set! *store-atime?* #t)
239    vals) ) )
240
241(define notes
242(option
243'(#\n "notes") #t #f
244(lambda (o n x vals)
245  (set! *snapshot-notes* (cons x *snapshot-notes*))
246  vals) ) )
247
248(define command-line
249   (reverse
250      (args-fold
251      (command-line-arguments)
252      (list help store-ctime store-atime notes)
253      (lambda (o n x vals)
254        (error "unrecognized option" n) )
255      cons
256      '())))
257
258
259; FIXME: Error checking. confpath exists, that sort of thing.
260(match command-line
261   (("snapshot" confpath tag fspath)
262      (let* ((configuration (with-input-from-file confpath read-file))
263             (archive (open-archive configuration *store-atime?* *store-ctime?*)))
264         
265         (printf "Archiving ~A to tag ~A...\n" fspath tag)
266         (define-values (dir-key dir-reused?)
267            (call-with-context-support
268             (archive-global-directory-rules archive)
269             (lambda () (store-directory! archive fspath))))
270         (printf "Root hash: ~A\n" dir-key)
271         (let ((snapshot-key (tag-snapshot! archive tag dir-key dir-reused? (list
272               (cons 'hostname (get-host-name))
273               (cons 'source-path fspath)
274               (cons 'notes *snapshot-notes*)))))
275            (printf "Successfully archived ~A to tag ~A\n" fspath tag)
276            (if (positive? (archive-file-cache-hits archive))
277                (printf "File cache has saved us ~A file hashings\n"
278                         (archive-file-cache-hits archive)))
279            (printf "Snapshot hash: ~A\n" snapshot-key)
280            (archive-close! archive))))
281     
282   (("explore" confpath)
283      (let ((archive (open-archive
284         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
285
286         (let/cc quit
287            (explore-archive archive '() '() quit))
288         (archive-close! archive)))
289         
290   (("fork" confpath tag newtag)
291      (let ((archive (open-archive
292         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
293         
294         (archive-set-tag! archive newtag (archive-tag archive tag))
295         (printf "Copied tag ~A to ~A\n" tag newtag)
296         (archive-close! archive)))
297   
298   (("cat" confpath key)
299      (let ((archive (open-archive
300         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
301         (let ((type (archive-exists? archive key))
302               (block (archive-get archive key)))
303               (printf "Block with key ~A (type ~A) is ~A bytes:\n" key type (u8vector-length block))
304               (write-u8vector block))
305           
306         (archive-close! archive)))
307   
308   (_
309      (printf "Invalid command line. Try \"ugarit -h\" for help.\n") (exit)))
310
311;; To explore the archive:
312;;         (let/cc quit
313;;            (explore-archive archive '() '() quit))
Note: See TracBrowser for help on using the repository browser.