(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 progress-total-files (make-parameter #f))
(define progress-total-bytes (make-parameter #f))

; It's vital to preserve this as the progress callback gets called
; in contexts with redirected output
(define progress-output-port (current-output-port))

; verbose, normal, quiet
(define *progress-verbosity* 'normal)

(define progress-interval 60)

(define (format-bytes b)
  (cond
   ((<= (* 1024 1024 1024 1024) b)
    (sprintf "~ATiB" (inexact->exact (round (/ b 1024 1024 1024 1024)))))
   ((<= (* 1024 1024 1024) b)
    (sprintf "~AGiB" (inexact->exact (round (/ b 1024 1024 1024)))))
   ((<= (* 1024 1024) b)
    (sprintf "~AMiB" (inexact->exact (round (/ b 1024 1024)))))
   ((<= (* 1024) b)
    (sprintf "~AKiB" (inexact->exact (round (/ b 1024)))))
   (else
    (sprintf "~AB" b))))

(define (percent a b)
  (inexact->exact
   (round
    (* 100 (/ a b)))))

(define progress-callback
  (let ((cpath #f)
        (csize #f)
        (bytes #f)
        (total-bytes 0)
        (total-files 0)
        (dir-depth 0)
        (next-progress-update (+ progress-interval (current-seconds))))
    (lambda (event path files size)
      (let ((update-due? (or (eq? *progress-verbosity* 'verbose)
                             (and
                              (eq? *progress-verbosity* 'normal)
                              (> (current-seconds)
                                 next-progress-update)))))
        #;(fprintf progress-output-port
                 "CALLBACK: ~A ~A ~A ~A ~A ~A\n"
                 event path files size
                 (- next-progress-update (current-seconds))
                 update-due?)
        (let ((prefix
               (sprintf "~A: [~A ~A]"
                        (epochtime->string (current-seconds))
                        (if (progress-total-files)
                            (sprintf "~A/~A files (~A%)"
                                     total-files
                                     (progress-total-files)
                                     (percent total-files (progress-total-files)))
                            "-")
                        (if (progress-total-bytes)
                            (sprintf "~A/~A (~A%)"
                                     (format-bytes total-bytes)
                                     (format-bytes (progress-total-bytes))
                                     (percent total-bytes (progress-total-bytes)))
                            "-"))))
         (case event
           ((file-start)
            (set! cpath path)
            (set! csize size)
            (set! bytes 0)
            (set! total-files (+ total-files 1)))
           ((file-block-start)
            (set! bytes (+ size bytes))
            (set! total-bytes (+ total-bytes size)))
           ((file-block-end)
            (when update-due?
                  (set! next-progress-update
                        (+ (current-seconds)
                           progress-interval))
                  (fprintf progress-output-port
                           "~A ~A (~A/~A [~A%])\n"
                           prefix
                           cpath
                           (format-bytes bytes) (format-bytes csize)
                           (percent bytes csize))))
           ((file-end)
            (when update-due?
                  (set! next-progress-update
                        (+ (current-seconds)
                           progress-interval))
                  (fprintf progress-output-port
                           "~A ~A (~A)\n"
                           prefix
                           cpath (format-bytes csize)))
            (set! cpath #f)
            (set! csize #f)
            (set! bytes #f))
           ((dir-start)
            (set! dir-depth
                  (+ dir-depth 1)))
           ((dir-end)
            (set! dir-depth
                  (- dir-depth 1)))))))))

(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 (assq 'size props)
       (printf " ~A" (cdr (assq 'size props)))
       (printf " -"))

   (when (assq 'files props)
       (printf "/~A" (cdr (assq 'files props))))

   (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-dirent! vault dirent name)
  (let* ((props (cddr dirent))
         (files (assq 'files props))
         (bytes (assq 'size props)))
   (parameterize
    ((progress-total-files (if files (cdr files) #f))
     (progress-total-bytes (if bytes (cdr bytes) #f)))
    (extract-object! vault dirent ".")))
  (printf "Extracted ~A\n" name))

(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)))
                            (dirent-name (car dirent)))
                      (if (string=? dirent-name name)
                          (begin
                            (extract-file-from-dirent! vault dirent
                                                       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>] [-q] [-v] <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
   -q --quiet         Do not log progress
   -v --verbose       Verbosely log progress
ugarit explore [-p] [-q] [-v] <path to ugarit.conf>
   ...explores the vault, allowing interactive extraction
   -p --check-correctness Perform extra consistency checks
   -q --quiet         Do not log progress
   -v --verbose       Verbosely log progress
ugarit fork <path to ugarit.conf> <tag> <new tag>
   ...copies a tag, forking the history
ugarit extract [-p] [-q] [-v] <path to ugarit.conf> <vault path>
   ...extracts the contents of a given path from the vault
      to the current directory
   -p --check-correctness Perform extra consistency checks
   -q --quiet         Do not log progress
   -v --verbose       Verbosely log progress
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 quiet
  (option
   '(#\q "quiet") #f #f
   (lambda (o n x vals)
     (set! *progress-verbosity* 'quiet)
     vals)))

(define verbose
  (option
   '(#\v "verbose") #f #f
   (lambda (o n x vals)
     (set! *progress-verbosity* 'verbose)
     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 quiet verbose)
      (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 progress-callback)))
      (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? files bytes)
           (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*)
                                             (cons 'files files)
                                             (cons 'size bytes))
                                            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 progress-callback)))
      (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)))))

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

         (handle-exceptions exn
            (begin
              (printf "ERROR: Could not extract ~a: ~a in ~a\n"
                      vaultpath
                      ((condition-property-accessor 'exn 'message "Unknown error") exn)
                      (cons ((condition-property-accessor 'exn 'location (void)) exn)
                            ((condition-property-accessor 'exn 'arguments '()) exn))))

            (let ((path (string-split vaultpath "/")))
              (let ((dirent (traverse-vault-path
                             vault
                             path)))
                (if dirent
                    (extract-file-from-dirent! vault (cdr dirent) (cadr dirent))
                    (printf "Cannot find ~A\n" vaultpath)))))

         (vault-close! vault)))))

   (("fork" confpath tag newtag)
    (let ((fork-job (make-job log-event! #f progress-callback)))
      (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)))))

   ; FIXME: Make this use traverse-vault-path
   ; and give traverse-vault-path a syntax for raw keys.
   (("cat" confpath key)
    (let ((cat-job (make-job log-event! #f progress-callback)))
      (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))