(use ugarit-core)
(use directory-rules)

(use srfi-37)
(use miscmacros)
(use matchable)
(use regex)

(define (bit? i b)
   (not (zero? (bitwise-and i b))))

(define (print-posix-mode mode)
   (if (bit? mode perm/irusr) (printf "r") (printf "-"))
   (if (bit? mode perm/iwusr) (printf "w") (printf "-"))
   (if (bit? mode perm/ixusr) (printf "x") (printf "-"))
   (if (bit? mode perm/irgrp) (printf "r") (printf "-"))
   (if (bit? mode perm/iwgrp) (printf "w") (printf "-"))
   (if (bit? mode perm/ixgrp) (printf "x") (printf "-"))
   (if (bit? mode perm/iroth) (printf "r") (printf "-"))
   (if (bit? mode perm/iwoth) (printf "w") (printf "-"))
   (if (bit? mode perm/ixoth) (printf "x") (printf "-")))

(define (print-long-dirent name type props)
   (case type
      ((file) (printf "-"))
      ((dir) (printf "d"))
      ((symlink) (printf "l"))
      ((fifo) (printf "p"))
      ((block-device) (printf "b"))
      ((character-device) (printf "c"))
      ((tag) (printf "t"))
      ((snapshot) (printf "s"))
      (else (printf "?")))
   
   (if (assq 'mode props)
      (print-posix-mode (cdr (assq 'mode props)))
      (printf "........."))
   
   (if (assq 'uid props) ; FIXME: pad to fixed width
      (printf " ~A" (cdr (assq 'uid props)))
      (printf " -"))

   (if (assq 'gid props) ; FIXME: pad to fixed width
      (printf " ~A" (cdr (assq 'gid props)))
      (printf " -"))
   
   (if (assq 'mtime props)
      (printf " ~A" (epochtime->string (cdr (assq 'mtime props))))
      (printf " -"))
   
   (if (and (eq? type 'symlink) (assq 'target props))
      (printf " ~A -> ~A\n" name (cdr (assq 'target props)))
      (printf " ~A\n" name)))
   
;; To get started, call (ls-archive archive '() long-format #f)
;; long-format is #f to just list names and types,
;; 'very to list EVERYTHING,
;; or #t to list long lines.
(define (ls-archive archive directory-key long-format match-re)
   (let ((*row* 0))
      (let/cc escape
         (fold-archive-node archive directory-key
            (lambda (node-key dirent acc)
               (let ((name (car dirent)))
                  (if (or (not match-re) (string-match match-re name))
                     (begin
                        (if (> *row* 20)
                           (begin
                              (printf "-- Press q then enter to stop or enter for more...\n")
                              (set! *row* 0)
                              (if (string=? (read-line) "q")
                                 (escape (void)))))
                        (inc! *row*)
                        (let ((type (cadr dirent))
                              (props (cddr dirent)))
               
                           (if long-format
                              (begin
                                 ; Print standard long line
                                 (print-long-dirent name type props)
                     
                                 (if (eq? long-format 'very)
                                    (begin
                                       (for-each 
                                          (lambda (prop) 
                                             (case (car prop)
                                                ((mode) (void))
                                                ((uid) (void))
                                                ((gid) (void))
                                                ((mtime) (void))
                                             (else (printf "~A: ~A\n" (car prop) (cdr prop)))))
                                          props)))))
                           (if (not long-format)
                              (printf "~A <~A>\n" name type))))
               
                        (void))))
                     (void)))))

(define (extract-file-from-node! archive directory-key name path success-continuation)
  (handle-exceptions exn
                     (begin
                       (printf "ERROR: Could not extract ~a: ~a in ~a\n"
                               name
                               ((condition-property-accessor 'exn 'message "Unknown error") exn)
                               (cons ((condition-property-accessor 'exn 'location (void)) exn)
                                     ((condition-property-accessor 'exn 'arguments (void)) exn)))
                       (success-continuation))
   (fold-archive-node archive directory-key
                      (lambda (node-key dirent acc)
                        (if (string=? (car dirent) name)
                            (case (cadr dirent)
                              ((tag) (begin
                                       (printf "You can't extract an entire tag - choose an actual snapshot at least\n")
                                       (success-continuation)))
                              ((snapshot)
                               (begin
                                 (define name (car path)) ; Head of path is the tag name - the best name we have available
                                 (if (not (directory? name))
                                     (create-directory name))

                                 (extract-directory! archive
                                                     (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot
                                                     name)
                                 (printf "Extracted ~A\n" name)
                                 (success-continuation)))
                              (else
                               (begin
                                 (extract-object! archive dirent ".")
                                 (printf "Extracted ~A\n" name)
                                 (success-continuation))))
                            acc))
                      #f)))

;; To get started, call with '() as directory-key and path
(define (explore-archive archive directory-key path quit-continuation)
   (printf "~A> " (apply string-append (map (lambda (element) (string-append "/" element)) path)))
   (let ((line (read-line)))
      (if (eq? line #!eof)
         (quit-continuation (void)))
      
      (let ((result (string-split line)))
  
         (match result
            (()
               (explore-archive archive directory-key path quit-continuation))
            (("help")
               (printf "cd .. : Go up one level\n")
               (printf "quit : leave Ugarit\n")
               (printf "ls [<pattern>] : list objects in the current directory\n")
               (printf "ls -l [<pattern>] : list objects and their core metadata\n")
               (printf "ls -ll [<pattern>] : list objects with a full list of metadata\n")
               (printf "cd <dir/tag/snapshot> : Go into a directory, tag, or snapshot\n")
               (printf "get <dir/file/object> : Extract something from the archive\n")
               (explore-archive archive directory-key path quit-continuation))
      
            (("cd" "..")
               (void)) ; Go up one level
            ((or ("bye") ("quit") ("exit"))
               (quit-continuation (void)))
            (("ls" "-l" . globparts)
               (if (null? globparts)
                  (ls-archive archive directory-key #t #f)
                  (ls-archive archive directory-key #t (glob->regexp (string-join globparts))))
               (explore-archive archive directory-key path quit-continuation))
            (("ls" "-ll" . globparts)
               (if (null? globparts)
                  (ls-archive archive directory-key 'very #f)
                  (ls-archive archive directory-key 'very (glob->regexp (string-join globparts))))
               (explore-archive archive directory-key path quit-continuation))
            (("ls" . globparts)
               (if (null? globparts)
                  (ls-archive archive directory-key #f #f)
                  (ls-archive archive directory-key #f (glob->regexp (string-join globparts))))
               (explore-archive archive directory-key path quit-continuation))
            (("cd" . dirparts)
               (let* ((dir (string-join dirparts))
                      (new-level
                         (fold-archive-node archive directory-key
                            (lambda (node-key dirent acc)
                               (if (string=? (car dirent) dir)
                                  node-key
                                  acc))
                            #f)))
                  (if new-level
                     (explore-archive archive new-level (reverse (cons dir (reverse path))) quit-continuation)
                     (printf "No such subdirectory ~A\n" dir))
                  (explore-archive archive directory-key path quit-continuation)))
            (("get" . nameparts)
               (let* ((name (string-join nameparts))
                      (success (extract-file-from-node! archive directory-key name path
                         (lambda ()
                            (explore-archive archive directory-key path quit-continuation)))))

                  (printf "No such file or directory ~A\n" name)

                  (explore-archive archive directory-key path quit-continuation)))
            (else
               (printf "Unknown command ~A\n" result)
               (explore-archive archive directory-key path quit-continuation))))))

;;
;; MAIN FUNCTION
;;

(define *store-ctime?* #f)
(define *store-atime?* #f)
(define *snapshot-notes* '())

(define help 
  (option 
   '(#\h "help") #f #f
   (lambda _ 
     (print "Usage:
ugarit snapshot <path to ugarit.conf> [-c] [-a] [-n <notes>] <tag> <path to root of filesystem>
   ...makes a snapshot of the given filesystem to the given tag in the archive identified by ugarit.conf
   -c --store-ctime   Store inode change/creation times in the archive
   -a --store-atime   Store file access times in the archive
   -n <notes> --notes=<notes>  Store notes with the snapshot
ugarit explore <path to ugarit.conf>
   ...explores the archive, allowing interactive extraction
ugarit fork <path to ugarit.conf> <tag> <new tag>
   ...copies a tag, forking the history
ugarit [-h|--help]
   ...shows this text")
     (exit) ) ) )

(define store-ctime
  (option
   '(#\c "store-ctime") #f #f
   (lambda (o n x vals)
     (set! *store-ctime?* #t)
     vals) ) )

(define store-atime
 (option
  '(#\a "store-atime") #f #f
  (lambda (o n x vals)
    (set! *store-atime?* #t)
    vals) ) )

(define notes
(option
'(#\n "notes") #t #f
(lambda (o n x vals)
  (set! *snapshot-notes* (cons x *snapshot-notes*))
  vals) ) )

(define command-line
   (reverse
      (args-fold
      (command-line-arguments)
      (list help store-ctime store-atime notes)
      (lambda (o n x vals)
        (error "unrecognized option" n) )
      cons
      '())))


; FIXME: Error checking. confpath exists, that sort of thing.
(match command-line
   (("snapshot" confpath tag fspath)
      (let* ((configuration (with-input-from-file confpath read-file))
	     (archive (open-archive configuration *store-atime?* *store-ctime?*)))
         
         (printf "Archiving ~A to tag ~A...\n" fspath tag)
         (define-values (dir-key dir-reused?)
            (call-with-context-support
	     (archive-global-directory-rules archive)
	     (lambda () (store-directory! archive fspath))))
         (printf "Root hash: ~A\n" dir-key)
         (let ((snapshot-key (tag-snapshot! archive tag dir-key dir-reused? (list
               (cons 'hostname (get-host-name))
               (cons 'source-path fspath)
               (cons 'notes *snapshot-notes*)))))
            (printf "Successfully archived ~A to tag ~A\n" fspath tag)
	    (if (positive? (archive-file-cache-hits archive))
		(printf "File cache has saved us ~A file hashings\n"
			 (archive-file-cache-hits archive)))
            (printf "Snapshot hash: ~A\n" snapshot-key)
            (archive-close! archive))))
      
   (("explore" confpath)
      (let ((archive (open-archive
         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))

         (let/cc quit
            (explore-archive archive '() '() quit))
         (archive-close! archive)))
         
   (("fork" confpath tag newtag)
      (let ((archive (open-archive
         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
         
         (archive-set-tag! archive newtag (archive-tag archive tag))
         (printf "Copied tag ~A to ~A\n" tag newtag)
         (archive-close! archive)))
   
   (("cat" confpath key)
      (let ((archive (open-archive
         (with-input-from-file confpath read-file) *store-atime?* *store-ctime?*)))
         (let ((type (archive-exists? archive key))
               (block (archive-get archive key)))
               (printf "Block with key ~A (type ~A) is ~A bytes:\n" key type (u8vector-length block))
               (write-u8vector block))
            
         (archive-close! archive)))
   
   (_
      (printf "Invalid command line. Try \"ugarit -h\" for help.\n") (exit)))

;; To explore the archive:
;;         (let/cc quit
;;            (explore-archive archive '() '() quit))