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

(use srfi-37)
(use miscmacros)
(use matchable)
(use regex)
(use parley)
(use parley-auto-completion)

(define current-vault (make-parameter #f))
(define current-directory-key (make-parameter '()))
(define *explore-commands*  '("bye" "cd" "exit" "get" "help" "ls" "quit")) ;; FIXME This is ugly

(define (log-event! event)
  (printf "~A\n" event))

(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-vault vault '() 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-vault vault directory-key long-format match-re)
   (let ((*row* 0))
      (let/cc escape
         (fold-vault-node vault 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: ~S\n" (car prop) (cdr prop)))))
                                          props)))))
                           (if (not long-format)
                              (printf "~A <~A>\n" name type))))
               
                        (void))))
                     (void)))))

(define (extract-file-from-node! vault 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 '()) exn)))
                       (success-continuation))
                     (let ((dirent (cdr (traverse-vault-node vault directory-key name))))
                      (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! vault
                                                   (cdr (assq 'contents (cddr dirent))) ; root directory of snapshot
                                                   name)
                               (printf "Extracted ~A\n" name)
                               (success-continuation)))
                            (else
                             (begin
                               (extract-object! vault dirent ".")
                               (printf "Extracted ~A\n" name)
                               (success-continuation))))
                          acc)
                      #f)))

;; To get started, call with '() as directory-key and path
(define (explore-vault vault directory-key path quit-continuation)
   (let ((line
          (parameterize ((current-vault vault)
                         (current-directory-key directory-key)
                         (completion-choices ugarit-tab-complete)
                         (word-class `(: (? (or ,@*explore-commands*)) (* whitespace) ($ (* any)))))
                        (parley (sprintf "~A> " (apply string-append (map (lambda (element) (string-append "/" element)) path)))))))
      (if (eq? line #!eof)
         (quit-continuation (void)))
      (let ((result (string-split line)))
         (match result
            (()
               (explore-vault vault 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 vault\n")
               (explore-vault vault directory-key path quit-continuation))

            (("cd" "..")
               (if (not (null? path)) ; Go up one level, if we aren't at the root already
                   (void)
                   (explore-vault vault directory-key path quit-continuation)))
            ((or ("bye") ("quit") ("exit"))
               (quit-continuation (void)))
            (("ls" "-l" . globparts)
               (if (null? globparts)
                  (ls-vault vault directory-key #t #f)
                  (ls-vault vault directory-key #t (glob->regexp (string-join globparts))))
               (explore-vault vault directory-key path quit-continuation))
            (("ls" "-ll" . globparts)
               (if (null? globparts)
                  (ls-vault vault directory-key 'very #f)
                  (ls-vault vault directory-key 'very (glob->regexp (string-join globparts))))
               (explore-vault vault directory-key path quit-continuation))
            (("ls" . globparts)
               (if (null? globparts)
                  (ls-vault vault directory-key #f #f)
                  (ls-vault vault directory-key #f (glob->regexp (string-join globparts))))
               (explore-vault vault directory-key path quit-continuation))
            (("cd" . dirparts)
               (let* ((dir (string-join dirparts))
                      (new-level
                       (traverse-vault-node vault directory-key dir)))
                  (if (and new-level (car new-level))
                     (explore-vault vault (car new-level) (reverse (cons dir (reverse path))) quit-continuation)
                     (printf "No such subdirectory ~A\n" dir))
                  (explore-vault vault directory-key path quit-continuation)))
            (("get" . nameparts)
               (let* ((name (string-join nameparts))
                      (success (extract-file-from-node! vault directory-key name path
                         (lambda ()
                            (explore-vault vault directory-key path quit-continuation)))))

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

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

;;
;; MAIN FUNCTION
;;

(define *check-correctness?* #f)
(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> [-p] [-c] [-a] [-n <notes>] <tag> <path to root of filesystem>
   ...makes a snapshot of the given filesystem to the given tag in the vault identified by ugarit.conf
   -p --check-correctness Perform extra consistency checks
   -c --store-ctime   Store inode change/creation times in the vault
   -a --store-atime   Store file access times in the vault
   -n <notes> --notes=<notes>  Store notes with the snapshot
ugarit explore [-p] <path to ugarit.conf>
   ...explores the vault, allowing interactive extraction
   -p --check-correctness Perform extra consistency checks
ugarit fork <path to ugarit.conf> <tag> <new tag>
   ...copies a tag, forking the history
ugarit [-h|--help]
   ...shows this text")
     (exit) ) ) )

(define check-correctness
  (option
   '(#\p "check-correctness") #f #f
   (lambda (o n x vals)
     (set! *check-correctness?* #t)
     vals)))

(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) ) )

;; Command line options override job defaults loaded
;; from the configuration file by open-vault
(define (override-job-options! job)
  (when *check-correctness?* 
        (set! (job-check-correctness? job) #t))
  
  (when *store-atime?* 
        (set! (job-store-atime? job) #t))
  
  (when *store-ctime?* 
        (set! (job-store-ctime? job) #t)))

(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 check-correctness store-ctime store-atime notes)
      (lambda (o n x vals)
        (error "unrecognized option" n) )
      cons
      '())))

(define ugarit-tab-complete
  (let* ()
    (lambda (input position last-word)
      (let ((words (length (string-split input " "))))
        (if (not (current-vault))
            '()
            (if (zero? words) ;; When there are no other words expand to a command
                *explore-commands*
                (fold-vault-node (current-vault)
                                 (current-directory-key)
                                 (lambda (key entry acc) (cons (car entry) acc))
                                 '())))))))

(add-key-binding! #\tab auto-completion-handler)

; FIXME: Error checking. confpath exists, that sort of thing.
(match command-line
   (("snapshot" confpath tag fspath)
    (let ((snapshot-job (make-job log-event! #t)))
      (parameterize ((current-job snapshot-job))
       (let* ((configuration (with-input-from-file confpath read-file))
              (vault (open-vault configuration)))

         (override-job-options! snapshot-job)

         (printf "Archiving ~A to tag ~A...\n" fspath tag)
         (define-values (dir-key dir-reused?)
           (call-with-context-support
            (vault-global-directory-rules vault)
            (lambda () (store-directory! vault fspath))))
         (printf "Root hash: ~A\n" dir-key)
         (let ((snapshot-key (tag-snapshot! vault tag dir-key dir-reused? (list
                                                                           (cons 'hostname (get-host-name))
                                                                           (cons 'source-path fspath)
                                                                           (cons 'notes *snapshot-notes*))
                                            snapshot-job)))
           (printf "Successfully snapshotted ~A to tag ~A\n" fspath tag)
           (printf "Snapshot hash: ~A\n" snapshot-key)
           (printf "Written ~A bytes to the vault in ~A blocks, and reused ~A bytes in ~A blocks (before compression)\n"
                   (job-bytes-stored snapshot-job)
                   (job-blocks-stored snapshot-job)
                   (job-bytes-skipped snapshot-job)
                   (job-blocks-skipped snapshot-job))
           (if (positive? (job-file-cache-hits snapshot-job))
               (printf "File cache has saved us ~A file hashings / ~A bytes (before compression)\n"
                       (job-file-cache-hits snapshot-job)
                       (job-file-cache-bytes snapshot-job)))
           (vault-close! vault))))))

   (("explore" confpath)
    (let ((explore-job (make-job log-event! #f)))
      (parameterize ((current-job explore-job))
       (let ((vault (open-vault
                     (with-input-from-file confpath read-file))))
         (override-job-options! explore-job)

         (let/cc quit
                 (explore-vault vault '() '() quit))
         (vault-close! vault)))))
         
   (("fork" confpath tag newtag)
    (let ((fork-job (make-job log-event! #f)))
      (parameterize ((current-job fork-job))
      (let ((vault (open-vault
         (with-input-from-file confpath read-file))))

         (override-job-options! fork-job)
         
         (vault-set-tag! vault newtag (vault-tag vault tag))
         (printf "Copied tag ~A to ~A\n" tag newtag)
         (vault-close! vault)))))
   
   (("cat" confpath key)
    (let ((cat-job (make-job log-event! #f)))
      (parameterize ((current-job cat-job))
      (let ((vault (open-vault
                    (with-input-from-file confpath read-file))))
        (override-job-options! cat-job)
        
        (let* ((type (vault-exists? vault key))
               (block (vault-get vault key type)))
          (printf "Block with key ~A (type ~A) is ~A bytes:\n" key type (u8vector-length block))
          (write-u8vector block))
            
        (vault-close! vault)))))
   
   (_
      (printf "Invalid command line. Try \"ugarit -h\" for help.\n") (exit)))

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