(module
 ugarit-api
 (open-vault ;; Note: Mutates job configuration from the conf file
  vault-close!

  ;; Re-exports from ugarit-core
  vault?
  vault-exists?
  vault-global-directory-rules

  make-job
  job?
  job-blocks-stored
  job-bytes-stored
  job-blocks-skipped

  tag-archive-import!
  merge-archive-tags!

  cache-import!
  search-archive
  list-archive-properties
  list-archive-property-values
  archive-get-entry

  ;; Re-exports from ugarit-vfs.scm
  fold-vault-node
  traverse-vault-node
  traverse-vault-path
  archive-entry->dirent)

 (import scheme)
 (import chicken)

 (use ugarit-backend)
 (use ugarit-core)
 (use ugarit-streams)

  tag-archive-import!
  merge-archive-tags!

  cache-import!
  search-archive
  list-archive-properties
  list-archive-property-values
  archive-get-entry)

(import scheme)
(import chicken)
(import extras)
(import ports)
(use ugarit-core)
(use ugarit-streams)

(define (make-object-ssql tag-name filter-ssql)
  `(select
    (distinct (columns archive_objects.key archive_objects.object_id archive_objects.import_id))
    (from (join inner
                archive_imports archive_objects
                (on (= archive_imports.import_id archive_objects.import_id))))
    (where (and (= archive_imports.tag ,tag-name) ,filter-ssql))))

; Returns one archive entry object, or #f
(define (archive-get-entry vault tag-name key)
    (let* ((db (vault-cache vault))
           (final-ssql `(select (columns prop value)
                                (from (join inner
                                            (join inner
                                                  archive_imports
                                                  archive_objects
                                                  (on (= archive_imports.import_id
                                                         archive_objects.import_id)))
                                            archive_entries
                                            (on (= archive_objects.object_id
                                                   archive_entries.object_id))))
                                (where (and
                                        (= archive_imports.tag ,tag-name)
                                        (= archive_objects.key ,key)))
                                (order (desc prop) value)))
           (final-sql (ssql->sql #f final-ssql))
           (results (query fetch-all (sql db final-sql))))
      (if (pair? results)
          (let ((alist (map
                        (lambda (row)
                          (let ((key (first row))
                                (prop (second row)))
                            (cons key prop)))
                        results)))
            (make-archive-entry key #t alist))
          ; else case, nothing found
          #f)))

; Returns a list of archive entry objects
(define (search-archive vault tag-name filter-expr)
  (update-cache-for-tag! vault tag-name)

                                        ; Now construct and run the query against the cache
  (let* ((db (vault-cache vault))

                      (lambda (dirent-sexpr acc)
                        (let ((dirent (make-dirent-from-sexpr dirent-sexpr)))
                         (condition-case
                          (begin
                            (extract-object!
                             vault
                             dirent
                             target-path
                             #t))
                          (exn (exn i/o file)
                               (job-log!
                                'error
                                (make-pathname target-path (dirent-name dirent))
                                (sprintf "Unable to extract from the vault (~a)"
                                         ((condition-property-accessor 'exn 'message "Unknown error") exn))))))
                        (void))
                      (void))
   (job-progress! 'dir-end #f #f #f)
   (void))

 (define (extract-object! vault dirent target-path use-object-name?)
   (let* ((type (dirent-type dirent))
          (name (dirent-name dirent))
          (props (dirent-props dirent))
          (target-name
           (if use-object-name?
               (make-pathname target-path name)
               target-path)))
     (cond
      ((eq? type 'file)
       (extract-file! vault props target-name))
      ((eq? type 'inline)
       (extract-inline! vault props target-name))
      ((eq? type 'tag)
       (signal (make-property-condition
                'exn
                'location 'extract-object!
                'dirent dirent
                'message "You can't extract an entire tag.")))
      ((eq? type 'root)
       (signal (make-property-condition
                'exn
                'location 'extract-object!
                'dirent dirent
                'message "You can't extract an entire vault.")))
      ((eq? type 'snapshot)
       (let ((output-path (make-pathname target-path name)))
         (if (not (directory? output-path))
             (create-directory output-path))
         (extract-directory! vault
                             (cdr (assq 'contents props))
                             output-path)))
      ((eq? type 'dir)
       (extract-subdirectory! vault props target-name))
      ((eq? type 'symlink)
       (extract-symlink! vault props target-name))
      ((eq? type 'fifo)
       (extract-fifo! vault props target-name))
      ((eq? type 'block-device)
       (extract-block-device! vault props target-name))
      ((eq? type 'character-device)
       (extract-character-device! vault props target-name))
      (else
       (job-log! 'error (make-pathname target-path name) (sprintf "Unable to extract an object of unknown type ~A" type))))))

 (define (fold-leaf-object vault dirent kons knil)
   (let ((type (dirent-type dirent))
         (name (dirent-name dirent))
         (props (dirent-props dirent)))

(module
 ugarit-vfs
 (                                      ; FIXME: These two will be useful in future
                                        ;verify-directory!
                                        ;verify-object!
  fold-history
  fold-vault-node
  traverse-vault-node
  traverse-vault-path

  archive-entry->dirent)

 (import scheme)
 (import chicken)
 (use ugarit-core)
 (use ugarit-streams)
 (use ugarit-files)
 (use ugarit-snapshot)

     (if (assq 'previous entry)
         (kons key entry
               (fold-history vault (cdr (assq 'previous entry)) type kons knil))
         (kons key entry knil))))

 ;; BRING IT ALL TOGETHER

(define (make-archive-object-name object-key object-props)
  (string-append
   object-key
   ":"
   (let* ((ae (make-archive-entry object-key #t object-props))
          (filenames (archive-entry-property ae 'filename))
          (names (archive-entry-property ae 'name)))
     (cond
      ((not (null? filenames))
       (car filenames))
      ((not (null? names))
       (string-append (car names) (archive-entry-guessed-extension ae)))
      (else
       (archive-entry-guessed-extension ae))))))

 (define (archive-entry->dirent type key props)
   (case type
     ((f fi) (make-dirent #f
                          (make-archive-object-name
                           key props)
                          'file
                          (cons
                           (cons 'contents key)
                           (cons
                            (cons 'mode
                                  perm/irusr)
                            props))))
     ((d di) (make-dirent key
                          (make-archive-object-name
                           key props)
                          'dir
                          (cons
                           (cons 'mode (+ perm/irusr perm/ixusr))
                           props)))
     (else (error 'archive-entry->dirent
                  "Unknown object type ~a" type))))

(define (make-inline-dirent name sexpr)
      (make-dirent
       #f
       name
       'inline
       `((text . ,(with-output-to-string
                    (lambda () (pp sexpr))))

      ((a ai)
       (fold-sexpr-stream vault directory-key 'a 'ai
                          (lambda (entry-sexpr acc)
                            (let* ((object-key (car entry-sexpr))
                                   (object-props (cdr entry-sexpr))
                                   (block-type (vault-exists? vault object-key)))
                              (kons

                               (archive-entry->dirent
                                block-type object-key object-props)











                               acc)))
                          knil)
       )
      ((d di)                              ; List directory contents
       (fold-sexpr-stream vault directory-key 'd 'di
                          (lambda (dirent-sexpr acc)
                            (kons (make-dirent-from-sexpr dirent-sexpr) acc))
                          knil))

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

                                          props)))))
                           (if (not long-format)
                              (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

              (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)))
      (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: ~a in ~a\n"
                      archive-tag hash
                      ((condition-property-accessor 'exn 'message "Unknown error") exn)
                      (cons ((condition-property-accessor 'exn 'location (void)) exn)
                            ((condition-property-accessor 'exn 'arguments '()) exn))))

            (let ((ae (archive-get-entry vault archive-tag hash)))
              (if ae
                  (let ((dirent (archive-entry->dirent
                                 (vault-exists? vault (archive-entry-key ae))
                                 (archive-entry-key ae)
                                 (archive-entry-alist 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)))
      (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: ~a in ~a\n"
                      archive-tag hash
                      ((condition-property-accessor 'exn 'message "Unknown error") exn)
                      (cons ((condition-property-accessor 'exn 'location (void)) exn)
                            ((condition-property-accessor 'exn 'arguments '()) exn))))

            (let ((ae (archive-get-entry vault archive-tag hash)))
              (if ae
                  (let ((dirent (archive-entry->dirent
                                 (vault-exists? vault (archive-entry-key ae))
                                 (archive-entry-key ae)
                                 (archive-entry-alist 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 (provide-default prop value alist)
  (if (assq prop alist)
      alist
      (cons (cons prop value) alist)))

               #f))

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

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

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

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

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

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

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

   ; 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