(use ugarit-api)
(use ugarit-mime)
(use directory-rules)

(use srfi-13)
(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" "cat" "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)))))
        (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)
  (fprintf (current-error-port) "~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 (pad len str)
  (string-pad (->string str) len))

(define (print-long-dirent name type props)
   (case type
     ;; Files, real and virtual
     ((file) (printf "-"))
     ((inline) (printf "="))

     ;; Funky filesystem objects
     ((symlink) (printf "l"))
     ((fifo) (printf "p"))
     ((block-device) (printf "b"))
     ((character-device) (printf "c"))

     ;; Actual directories
     ((dir) (printf "d"))

     ;; Virtual directories
     ((tag) (printf "D"))
     ((snapshot) (printf "D"))
     ((archive-history) (printf "D"))
     ((import) (printf "D"))
     ((import-manifest) (printf "D"))

     ;; Things I have forgotten to implement
     (else (printf "~a" type)))

   (if (assq 'mode props)
      (print-posix-mode (cdr (assq 'mode props)))
      (printf "         "))

   (printf " ~A"
           (pad 5
                (if (assq 'uid props)
                    (cdr (assq 'uid props))
                    "-")))

   (printf " ~A"
           (pad 5
                (if (assq 'gid props)
                    (cdr (assq 'gid props))
                    "-")))

   (if (assq 'mtime props)
      (printf " [~A]" (epochtime->string (cdr (assq 'mtime props))))
      (printf " [                   ]"))

   (printf " ~A"
           (if (assq 'size props)
               (format-bytes (cdr (assq 'size props)))
               "-"))

   (if (assq 'files props)
       (printf "/~A" (cdr (assq 'files 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 (dirent acc)
               (let ((name (dirent-name 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 (dirent-type dirent))
                              (props (dirent-props dirent)))

                           (if long-format
                              (begin
                                 ; Print standard long line
                                 (print-long-dirent name type props)

                                 (if (eq? long-format 'very)
                                    (begin
                                      (printf "key: ~S\n" (dirent-subnode-key dirent))
                                       (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)
                               (if (dirent-subnode-key dirent)
                                (printf "~A/ <~A>\n" name type)
                                (printf "~A <~A>\n" name type)))))

                        (void))))
                     (void)))))

(define (extract-file-from-dirent! vault dirent target use-object-name?)
  (let* ((props (dirent-props 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 target use-object-name?)))
  (printf "Extracted ~A into ~A\n" (dirent-name dirent) target))

(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 (traverse-vault-node vault
                                                         directory-key
                                                         name)))
                      (if (string=? (dirent-name dirent) name)
                          (begin
                            (extract-file-from-dirent! vault dirent
                                                       "." #t)
                            (success-continuation))
                          acc))
                      #f))

(define (cat-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 (traverse-vault-node vault
                                                         directory-key
                                                         name)))
                      (if (string=? (dirent-name dirent) name)
                          (begin
                            (fold-leaf-object
                             vault dirent
                             (lambda (block acc)
                               (write-u8vector block)
                               acc)
                             #f)
                            (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")
               (printf "cat <file> : Display the contents of a file\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 (dirent-subnode-key new-level))
                     (explore-vault vault (dirent-subnode-key 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)))
            (("cat" . nameparts)
             (let* ((name (string-join nameparts))
                    (success (cat-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))))))

(define (do-snapshot! confpath tag fspath)
  (let ((snapshot-job (make-job log-event! #t progress-callback)))
    (call-with-job-context snapshot-job
                           (lambda ()
                             (let* ((configuration (with-input-from-file confpath read-file))
                                    (vault (open-vault configuration)))

                               (override-job-options! snapshot-job)

                               (printf "Snapshotting ~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 to the vault in ~A blocks, and reused ~A in ~A blocks (before compression)\n"
                                         (format-bytes (job-bytes-stored snapshot-job))
                                         (job-blocks-stored snapshot-job)
                                         (format-bytes (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 (before compression)\n"
                                             (job-file-cache-hits snapshot-job)
                                             (format-bytes (job-file-cache-bytes snapshot-job))))
                                 (vault-close! vault)))))))

(define (do-import! confpath tag manifest-path)
  (let ((import-job (make-job log-event! #t progress-callback)))
    (set! (job-use-rules? import-job) #f) ; Disable .ugarit / rules processing
    (call-with-job-context import-job
                           (lambda ()
                             (let* ((configuration (with-input-from-file confpath read-file))
                                    (vault (open-vault configuration)))

                               (override-job-options! import-job)
                               (printf "Loading manifest file ~A...\n" manifest-path)
                               (receive
                                (import-props manifest)
                                (load-manifest vault tag manifest-path)

                                (printf "Importing from ~A to tag ~A...\n" manifest-path tag)
                                (let ((entries
                                       (map (lambda (entry)
                                              (let ((fspath (car entry))
                                                    (props (cdr entry)))
                                                (printf "Importing ~A...\n" fspath)
                                                (receive (key reused? files bytes)
                                                         (if (directory? fspath)
                                                             ;; Import a directory
                                                             (call-with-context-support
                                                              (vault-global-directory-rules vault)
                                                              (lambda () (store-directory! vault fspath)))
                                                             ;; Import a bare file
                                                             (receive (key reused?)
                                                                      (store-file! vault fspath
                                                                                   (file-stat fspath #t))
                                                                      (values key reused? 1 (file-size fspath))))
                                                         ;; Now make an archive entry of it
                                                         (if reused?
                                                             (printf "...already exists with key ~A\n" key)
                                                             (printf "...imported with key ~A\n" key))
                                                         (make-archive-entry key reused? props))))
                                            manifest))
                                      (entries-hash (make-hash-table)))

                                  ;; Check for collisions
                                  (for-each
                                   (lambda (ae)
                                     (let ((key (archive-entry-key ae)))
                                       (when
                                        (hash-table-exists? entries-hash key)
                                        (let ((new-path
                                               (cdr (assq 'import-path
                                                          (archive-entry-alist ae))))
                                              (old-path
                                               (cdr (assq 'import-path
                                                          (archive-entry-alist
                                                           (hash-table-ref entries-hash key))))))

                                          (job-log!
                                           'warning
                                           new-path
                                           (sprintf "The file ~a has the same content as ~a from the same manifest, so the metadata assigned to ~a will be used and the metadata for ~a ignored."
                                                    new-path old-path new-path old-path))))
                                       (hash-table-set! entries-hash key ae)))
                                   entries)

                                  ;; Now make the import
                                  (printf "Committing import...\n")
                                  (let ((import-key
                                         (tag-archive-import! vault
                                                              tag
                                                              (hash-table-values entries-hash)
                                                              import-props
                                                              import-job)))
                                    (printf "Imported successfully to tag ~A with import key ~A\n"
                                            tag import-key)

                                    (printf "Written ~A to the vault in ~A blocks, and reused ~A in ~A blocks (before compression)\n"
                                            (format-bytes (job-bytes-stored import-job))
                                            (job-blocks-stored import-job)
                                            (format-bytes (job-bytes-skipped import-job))
                                            (job-blocks-skipped import-job))
                                    (if (positive? (job-file-cache-hits import-job))
                                        (printf "File cache has saved us ~A file hashings / ~A (before compression)\n"
                                                (job-file-cache-hits import-job)
                                                (format-bytes (job-file-cache-bytes import-job))))
                                    (vault-close! vault)))))))))

(define (do-explore! confpath)
  (let ((explore-job (make-job log-event! #f progress-callback)))
    (call-with-job-context explore-job
                           (lambda ()
                             (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))))))

(define (do-search confpath archive-tag filter fmt)
    (let ((search-job (make-job log-event! #f progress-callback)))
      (call-with-job-context
       search-job
       (lambda ()
         (let ((vault (open-vault
                       (with-input-from-file confpath read-file))))
           (override-job-options! search-job)

           (for-each
            (lambda (ae)
              (case fmt
                ((keys)
                 (printf "~a\n" (archive-entry-key ae)))
                ((alist)
                 (pp `(,(archive-entry-key ae) . ,(archive-entry-alist ae))))
                ((alist-with-imports)
                 (let ((ai (archive-entry-import ae)))
                   (pp `(,(archive-entry-key ae)
                         ,(archive-entry-alist ae)
                         ,(archive-import-key ai)
                         ,(archive-import-alist ai)))))
                ((verbose)
                 (printf "object ~a\n" (archive-entry-key ae))
                 (for-each
                  (lambda (pe)
                    (printf "\t(~s = ~s)\n" (car pe) (cdr pe)))
                  (archive-entry-alist ae))
                 (let ((ai (archive-entry-import ae)))
                   (printf "\timport ~a\n" (archive-import-key ai))
                   (for-each
                    (lambda (pe)
                      (printf "\t\t(~s = ~s)\n" (car pe) (cdr pe)))
                    (archive-import-alist ai))))
                (else
                 (printf "~a\n" (dirent-name (archive-entry->dirent vault ae))))))
            (search-archive vault
                            archive-tag filter))

                                   (vault-close! vault))))))

(define (do-search-props confpath archive-tag filter)
    (let ((search-job (make-job log-event! #f progress-callback)))
      (call-with-job-context search-job
       (lambda ()
         (let ((vault (open-vault
                       (with-input-from-file confpath read-file))))
           (override-job-options! search-job)

          (for-each
           (lambda (prop-name)
             (printf "~a\n" prop-name))
           (list-archive-properties vault
                                    archive-tag filter))

          (vault-close! vault))))))

(define (do-search-values confpath archive-tag filter prop-name)
    (let ((search-job (make-job log-event! #f progress-callback)))
      (call-with-job-context search-job
       (lambda ()
         (let ((vault (open-vault
                       (with-input-from-file confpath read-file))))
           (override-job-options! search-job)

           (for-each
            (lambda (prop-value)
              (printf "~a\n" prop-value))
            (list-archive-property-values vault
                                          archive-tag filter prop-name))

           (vault-close! vault))))))

(define (do-extract! confpath vaultpath target)
    (let ((extract-job (make-job log-event! #f progress-callback)))
      (call-with-job-context extract-job
       (lambda ()
         (let ((vault (open-vault
                       (with-input-from-file confpath read-file))))
           (override-job-options! extract-job)

          (let ((path (string-split vaultpath "/")))
            (let ((dirent (traverse-vault-path
                           vault
                           path)))
              (if dirent
                  (extract-file-from-dirent! vault dirent
                                             (if target
                                                 target
                                                 ".")
                                             (if target
                                                 #t
                                                 #f))
                  (printf "Cannot find ~A\n" vaultpath))))

          (vault-close! vault))))))

(define (do-archive-extract! confpath archive-tag hash target)
    (let ((extract-job (make-job log-event! #f progress-callback)))
      (call-with-job-context extract-job
       (lambda ()
         (let ((vault (open-vault
                       (with-input-from-file confpath read-file))))
           (override-job-options! extract-job)

           (let ((ae (archive-get-entry vault archive-tag hash)))
             (if ae
                 (let ((dirent (archive-entry->dirent
                                vault ae)))
                   (extract-file-from-dirent! vault dirent
                                              target #f))
                 (printf "Cannot find ~A in ~A\n" hash archive-tag)))

          (vault-close! vault))))))

(define (do-archive-stream! confpath archive-tag hash)
    (let ((extract-job (make-job log-event! #f progress-callback)))
      (call-with-job-context extract-job
       (lambda ()
         (let ((vault (open-vault
                       (with-input-from-file confpath read-file))))
           (override-job-options! extract-job)

          (let ((ae (archive-get-entry vault archive-tag hash)))
            (if ae
                (let ((dirent (archive-entry->dirent
                               vault ae)))
                  (fold-leaf-object
                   vault dirent
                   (lambda (block acc)
                     (write-u8vector block)
                     acc)
                   #f))
                (fprintf (current-error-port)
                         "Cannot find ~A in ~A\n" hash archive-tag)))

          (vault-close! vault))))))

(define (do-fork! confpath tag newtag)
  (let ((fork-job (make-job log-event! #f progress-callback)))
    (call-with-job-context fork-job
                           (lambda ()
                             (let ((vault (open-vault
                                           (with-input-from-file confpath read-file))))

                               (override-job-options! fork-job)

                               (vault-fork-tag! vault tag newtag)

                               (printf "Copied tag ~A to ~A\n"
                                       tag newtag)
                               (vault-close! vault))))))

(define (do-merge! confpath newtag tags)
  (let ((merge-job (make-job log-event! #f progress-callback)))
    (call-with-job-context merge-job
                           (lambda ()
                             (let ((vault (open-vault
                                           (with-input-from-file confpath read-file))))

                               (override-job-options! merge-job)

                               (vault-merge-tags! vault newtag tags)

                               (printf "Merged tags ~A to ~A\n"
                                       tags newtag)
                               (vault-close! vault))))))

(define (provide-default prop value alist)
  (if (assq prop alist)
      alist
      (cons (cons prop value) alist)))

(define (read-prop prop)
  (match prop
         ((key '= value)
          (unless (symbol? key)
                  (error 'import
                         "Object property names must be symbols"
                         key))
          (cons key value))
         (else
          (error 'import
                 (sprintf "This is not a valid manifest-file property: ~S"
                          prop)))))

(define (just-the-filename path)
  (let ((last-slash-pos (string-index-right path #\/)))
    (if last-slash-pos
        (substring/shared path (+ 1 last-slash-pos))
        path)))

(define (validate-readable! path)
  (if (directory? path)
      (begin
        (unless
         (and (file-execute-access? path)
              (file-read-access? path))
         (error 'import
                (sprintf "The directory ~a is not readable" path)
                path))
        (for-each
         (lambda (fn)
           (validate-readable!
            (make-pathname path fn)))
         (directory path)))
      (unless
       (file-read-access? path)
       (error 'import
              (sprintf "The file ~a is not readable" path)
              path))))

(define (load-manifest vault tag manifest-path)
  (let ((state (with-input-from-file manifest-path
                 (lambda ()
                   (port-fold
                    (lambda (entry state)
                      (match
                       entry
                       ((key '= value)
                        (unless (symbol? key)
                                (error 'import
                                       "Import property names must be symbols"
                                       key))
                        (cons
                         (cons (cons key value)
                               (car state))
                         (cdr state)))
                       (('object fspath . props)
                        (unless (string? fspath)
                                (error 'import
                                       "Object entries must start with a filesystem path"
                                       fspath))
                        (validate-readable! fspath)

                        (let* ((supplied-props (map read-prop props))
                               (props1
                                (provide-default
                                 'import-path
                                 fspath
                                 supplied-props))
                               (props2
                                (provide-default
                                 'dc:format
                                 (if (directory? fspath)
                                     "inode/directory"
                                     (extension->mimetype
                                      (extension-from-filename fspath)))
                                 props1))
                               (stat
                                (file-stat fspath))
                               (props3
                                (provide-default
                                 'mtime
                                 (vector-ref stat 8)
                                 props2))
                               (props4
                                (provide-default
                                 'ctime
                                 (vector-ref stat 7)
                                 props3))
                                (final-props
                                 (provide-default
                                  'filename
                                  (just-the-filename fspath)
                                  props4)))
                          (cons
                           (car state)
                           (cons (cons fspath
                                       final-props)
                                 (cdr state)))))
                       (else
                        (error 'import
                               (sprintf "This is not a valid manifest-file entry: ~S"
                                        entry)))))
                    ;; Fold state: car is import props, cdr is alist of objects

                    `(
                      ;; Default import properties
                      ((hostname . ,(get-host-name))
                       (manifest-path . ,manifest-path))
                      .
                      ;; Default object list (empty)
                      ())
                    read)))))

    ;; Scan object alist for duplicated filenames
    ;; This won't avoid all duplication, as the same content
    ;; can appear in more than one file, but now's a good point to
    ;; illustrate a problem.

    (let ((pathnames (make-hash-table)))
      (for-each
       (lambda (entry)
         (when
          (hash-table-exists? pathnames (car entry))
          (error 'import
                 (sprintf "The path ~a appears more than once in the manifest"
                          (car entry))
                 (car entry)))
         (hash-table-set! pathnames (car entry) #t))
       (cdr state)))

    (values
     ;; Import props
     (car state)
     ;; Objects
     (cdr state))))

;;
;; 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 merge <path to ugarit.conf> <new tag> <input tag 1> <input tag 2>...
   ...merges two or more tags, joining the histories
ugarit extract [-p] [-q] [-v] <path to ugarit.conf> <vault path> [<target path>]
   ...extracts the contents of a given path from the vault
      to the current directory, or to the target path.
   -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 (check-confpath confpath)
  (unless
   (file-read-access? confpath)
   (fprintf
    (current-error-port)
    "ERROR: The configuration file ~a is not readable\n" confpath)
   (exit 1)))

(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 (entry acc) (cons (dirent-name entry) acc))
                                 '())))))))

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

(match command-line
       (("snapshot" confpath tag fspath)
        (check-confpath confpath)
        (do-snapshot! confpath tag fspath))

       (("import" confpath tag manifest-path)
        (check-confpath confpath)
        (do-import! confpath tag manifest-path))

       (("explore" confpath)
        (check-confpath confpath)
        (do-explore! confpath))

       (("extract" confpath vaultpath)
        (check-confpath confpath)
        (do-extract! confpath vaultpath #f))

       (("extract" confpath vaultpath target)
        (check-confpath confpath)
        (do-extract! confpath vaultpath target))

       (("search" confpath archive-tag filter)
        (check-confpath confpath)
        (do-search confpath archive-tag
                   (with-input-from-string filter read)
                   #f))

       (("search" confpath archive-tag filter format)
        (check-confpath confpath)
        (do-search confpath archive-tag
                   (with-input-from-string filter read)
                   (string->symbol format)))

       (("search-props" confpath archive-tag)
        (check-confpath confpath)
        (do-search-props confpath archive-tag #t))

       (("search-props" confpath archive-tag filter)
        (check-confpath confpath)
        (do-search-props confpath archive-tag
                         (with-input-from-string filter read)))

       (("search-values" confpath archive-tag prop-name)
        (check-confpath confpath)
        (do-search-values confpath archive-tag
                          #t
                          (string->symbol prop-name)))

       (("search-values" confpath archive-tag filter prop-name)
        (check-confpath confpath)
        (do-search-values confpath archive-tag
                          (with-input-from-string filter read)
                          (string->symbol prop-name)))

       ;; IDEA: search-import-props, search-import-values
       ;; using list-import-properties and list-import-property-values
       ;; from ugarit-archive.scm, when implemented.

       (("archive-extract" confpath archive-tag hash target)
        (check-confpath confpath)
        (do-archive-extract! confpath archive-tag hash target))

       (("archive-stream" confpath archive-tag hash)
        (check-confpath confpath)
        (do-archive-stream! confpath archive-tag hash))

       ;; For debugging
       (("cat" confpath key)
        (check-confpath confpath)
        (let ((cat-job (make-job log-event! #f progress-callback)))
          (call-with-job-context cat-job
                                 (lambda ()
                                   (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))))))

       (("fork" confpath tag newtag)
        (check-confpath confpath)
        (do-fork! confpath tag newtag))

       (("merge" confpath newtag . tags)
        (check-confpath confpath)
        (do-merge! confpath newtag tags))

       (_
        (printf "Invalid command line. Try \"ugarit -h\" for help.\n") (exit)))