source: project/release/3/ugarit/trunk/ugarit.scm @ 13103

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

V0.2 ready to roll

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