(use miscmacros)

(include "ugarit-core.scm")

(define (test-backend w)
   (assert (storage-writable? w))
   (assert (not ((storage-exists? w) "TEST")))
   ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test)
   (assert ((storage-exists? w) "TEST"))
   (assert (equal? (u8vector->list ((storage-get w) "TEST")) (list 1 2 3 4 5)))
   (if (storage-unlinkable? w)
      (begin
         (assert (equal? (u8vector->list ((storage-unlink! w) "TEST")) (list 1 2 3 4 5)))
         (assert (not ((storage-exists? w) "TEST")))))
   ((storage-set-tag! w) "TEST" "TEST123")
   (assert (equal? ((storage-tag w) "TEST") "TEST123"))
   (assert (equal? ((storage-all-tags w)) (list "TEST")))
   ((storage-remove-tag! w) "TEST")
   "This backend seems to work!")

(create-directory "./tmp/be1")
(define be (backend-fs "./tmp/be1"))
(printf "backend-fs: ~A\n" (test-backend be))
((storage-close! be))

(create-directory "./tmp/be2")
(define be (backend-log "./tmp/be2/log" "./tmp/be2/index" "./tmp/be2/tags"))
(printf "backend-log: ~A\n" (test-backend be))
((storage-close! be))

(create-directory "./tmp/be2a")
(define be (backend-splitlog "./tmp/be2a" "./tmp/be2a" 1024))
(printf "backend-splitlog: ~A\n" (test-backend be))
((storage-close! be))

(create-directory "./tmp/be3")
(define be (backend-fs "./tmp/be3"))
(define cbe (backend-cache be "./tmp/be3-cache"))
(printf "backend-cache(backend-fs): ~A\n" (test-backend cbe))
((storage-close! cbe))

(create-directory "./tmp/be4")
(define be (backend-fs "./tmp/be4"))
(define cbe (backend-cache be "./tmp/be4-cache"))
(define lbe (backend-limit-block-size cbe 1024)) 
(printf "backend-limit-block-size(backend-cache(backend-fs)): ~A\n" (test-backend lbe))
((storage-close! lbe))

(define (key-stream-cat a ks-hash ks-type level)
   (define type (archive-exists? a ks-hash))
   (if (eq? type ks-type)
      (begin
         (printf "ks(~A): ~A (~A)\n" level ks-hash type)
            (for-each (lambda (subkey)
               (key-stream-cat a subkey ks-type (+ level 1)))
               (deserialise-key-stream (archive-get a ks-hash))))
      (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))

(define (sexpr-stream-cat a ss-hash leaf-type ss-type level)
   (define type (archive-exists? a ss-hash))
   (cond
      ((eq? type ss-type)
         (begin ; key stream node
            (printf "ss(~A): ~A (~A)\n" level ss-hash type)
               (for-each (lambda (subkey)
                  (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1)))
                  (deserialise-key-stream (archive-get a ss-hash)))))
      ((eq? type leaf-type)
         (begin ; leaf node
            (printf "sleaf(~A): ~A (~A)\n" level ss-hash type)
               (for-each (lambda (sexpr)
                  (printf " ~A\n" sexpr))
                  (deserialise-sexpr-stream (archive-get a ss-hash)))))
      (else
         (assert (or (eq? type ss-type) (eq? type leaf-type))))))


(define (check-dir-is-empty store-path)
   (assert (null? (directory store-path))))

(define (test-archive a store-path)
   (if (archive-unlinkable? a)
      (check-dir-is-empty store-path)) ; Precondition
   
   (printf "Testing basic archive operations...\n")
   (define test-list (list 1 2 3 4 5))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (assert (archive-writable? a))
   (assert (not (archive-exists? a test-key)))
   (archive-put! a test-key test-data 'test)
   (assert (archive-exists? a test-key))
   (assert (equal? (u8vector->list (archive-get a test-key)) test-list))
   (if (archive-unlinkable? a)
      (begin
         (assert (equal? (u8vector->list (archive-unlink! a test-key)) test-list))
         (assert (not (archive-exists? a test-key)))))
   (archive-set-tag! a "TEST" test-key)
   (assert (equal? (archive-tag a "TEST") test-key))
   (assert (equal? (archive-all-tags a) (list "TEST")))
   (archive-remove-tag! a "TEST")
   (if (archive-unlinkable? a)
      (check-dir-is-empty store-path))

   (printf "Testing 0-element key stream...\n")
   (define test-list (list 1 2 3 4 5 6))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ksw (make-key-stream-writer* a 'test-ks))
   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
   (assert (not ks-reused?))
   (assert (string=? ks-hash "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3test-ks"))
   (assert (equal? (fold-key-stream archive ks-hash 'test-ks cons '()) '()))
   (if (archive-unlinkable? a)
      (begin
         (assert (archive-unlink! a ks-hash))
         (check-dir-is-empty store-path)))

   (printf "Testing 1-element key stream...\n")
   (define test-list (list 1 2 3 4 5 6 7))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ksw (make-key-stream-writer* a 'test-ks))
   (archive-put! a test-key test-data 'test)
   ((key-stream-writer-write! ksw) test-key #f)
   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
   (assert (not ks-reused?))
   (assert (string=? ks-hash test-key))
   
   (define keys (fold-key-stream archive ks-hash 'test-ks 
      (lambda (key type acc)
         (cons (cons key type) acc)) '()))
   (assert (equal? keys (list (cons test-key 'test))))
   
   (if (archive-unlinkable? a)
      (begin
         (assert (archive-unlink! a test-key))
         (check-dir-is-empty store-path)))

   (printf "Testing 2-element key stream...\n")
   (define test-list (list 1 2 3 4 5 6 7 8))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ksw (make-key-stream-writer* a 'test-ks))
   (archive-put! a test-key test-data 'test)
   ((key-stream-writer-write! ksw) test-key #f)
   ((key-stream-writer-write! ksw) test-key #t)
   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
   (assert (not ks-reused?))
   
   (assert (archive-exists? a ks-hash))
   
   (define keys (fold-key-stream archive ks-hash 'test-ks 
      (lambda (key type acc)
         (cons (cons key type) acc)) '()))
   (assert (equal? keys (list (cons test-key 'test) (cons test-key 'test))))
   
   (if (archive-unlinkable? a)
      (begin
         (assert (archive-unlink! a ks-hash))
         (assert (not (archive-unlink! a test-key)))
         (assert (archive-unlink! a test-key))
         (check-dir-is-empty store-path)))
   
   (define iterations 1024)
   (printf "Testing ~A-element key stream...\n" iterations)
   (define test-list (list 1 2 3 4 5 6 7 8 9))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ksw (make-key-stream-writer* a 'test-ks))
   (archive-put! a test-key test-data 'test)

   ((key-stream-writer-write! ksw) test-key #t) ; ensure one reference is left
   (dotimes (iter iterations)
      ((key-stream-writer-write! ksw) test-key #t))

   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
   (assert (not ks-reused?))

;   (key-stream-cat archive ks-hash 'test-ks 0)
   
   (define keys (fold-key-stream archive ks-hash 'test-ks 
      (lambda (key type acc)
         (cons (cons key type) acc)) '()))
   (assert (= (length keys) (+ 1 iterations)))
   (assert (every
      (lambda (key) (string=? (car key) test-key))
      keys))
   
   (if (archive-unlinkable? a)
      (begin
         (unlink-key-stream! archive ks-hash 'test-ks
            (lambda (archive key type)
               (assert (not (archive-unlink! archive key)))))
   
         (assert (archive-unlink! a test-key)) ; clean up the one final reference
         (check-dir-is-empty store-path)))
   
   (printf "Testing 0-element sexpr stream...\n")
   (define test-list (list 1 2 3 4 5 6 7 8 9 10))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ssw (make-sexpr-stream-writer* a 't 'ti))
   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
   (assert (not ss-reused?))
   (assert (string=? ss-hash "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3t"))
   (assert (equal? (fold-sexpr-stream archive ss-hash 't 'ti cons '()) '()))
   (if (archive-unlinkable? a)
      (begin
         (assert (archive-unlink! a ss-hash))
         (check-dir-is-empty store-path)))

   (printf "Testing 1-element sexpr stream...\n")
   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ssw (make-sexpr-stream-writer* a 't 'ti))
   (archive-put! a test-key test-data 'test)
   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
   (assert (not ss-reused?))
   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
   (assert (equal? sexprs `((foo ,test-key))))
   (if (archive-unlinkable? a)
      (begin
         (unlink-sexpr-stream! archive ss-hash 't 'ti
            (lambda (sexpr)
               (assert (equal? sexpr `(foo ,test-key)))
               (archive-unlink! archive test-key)))
         (assert (not (archive-exists? archive ss-hash)))
         (assert (not (archive-exists? archive test-key)))
         (check-dir-is-empty store-path)))

   (printf "Testing 2-element sexpr stream...\n")
   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ssw (make-sexpr-stream-writer* a 't 'ti))
   (archive-put! a test-key test-data 'test)
   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
   (assert (not ss-reused?))
   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
   (assert (equal? sexprs `((foo ,test-key) (foo ,test-key))))

   (if (archive-unlinkable? a)
      (begin
         (unlink-sexpr-stream! archive ss-hash 't 'ti
            (lambda (sexpr)
               (assert (equal? sexpr `(foo ,test-key)))
               (archive-unlink! archive test-key)))
         (assert (not (archive-exists? archive ss-hash)))
         (assert (not (archive-exists? archive test-key)))
         (check-dir-is-empty store-path)))
   
   (printf "Testing ~A-element sexpr stream...\n" iterations)
   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13))
   (define test-data (list->u8vector test-list))
   (define test-key ((archive-hash a) test-data 'test))
   (define ssw (make-sexpr-stream-writer* a 't 'ti))
   (archive-put! a test-key test-data 'test)
   (dotimes (iter iterations)
      ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
   (assert (not ss-reused?))
   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
   (assert (= (length sexprs) iterations))
   (assert (every
      (lambda (sexpr) (equal? sexpr `(foo ,test-key)))
      sexprs))

   ;(sexpr-stream-cat a ss-hash 't 'ti 0)

   (if (archive-unlinkable? a)
      (begin
         (unlink-sexpr-stream! archive ss-hash 't 'ti
            (lambda (sexpr)
               (assert (equal? sexpr `(foo ,test-key)))
               (archive-unlink! archive test-key)))
   
         (assert (not (archive-exists? archive test-key)))
         (check-dir-is-empty store-path)))
   
   (printf "Testing files...\n")
   (define test-string "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")
   
   (printf "\tStore a file\n")
   (define-values (file-key file-reused?)
      (with-input-from-string test-string (lambda ()
         (store-file! archive))))

   (printf "\tRead it back\n")
   (define result (with-output-to-string
      (lambda ()
         (write-file-contents archive file-key))))
   
   (assert (string=? test-string result))
   
   (if (archive-unlinkable? a)
      (begin
         (printf "\tDelete the file\n")
         (unlink-file! archive file-key)
         (check-dir-is-empty store-path)))
   
   (printf "Testing directories...\n")
   
   (printf "\tStore a directory\n")
   
   (define-values (dir-key dir-reused?)
      (store-directory! archive "test-data"))

   (printf "\tExtract the directory\n")
   (create-directory (string-append store-path "-extract"))
   (extract-directory! archive dir-key (string-append store-path "-extract"))
   
   (if (archive-unlinkable? a)
      (begin
         (printf "\tDelete the directory\n")
         (unlink-directory! archive dir-key)
         (check-dir-is-empty store-path)))
   
   (printf "Testing snapshots\n")

   (printf "\tStore a directory\n")
   
   (define-values (dir-key dir-reused?)
      (store-directory! archive "test-data"))

   (if (archive-unlinkable? a)
      (assert (not dir-reused?)))

   (printf "\tTag it (~A ~A)\n" dir-key dir-reused?)
   (define sk1 (tag-snapshot! archive "Test" dir-key dir-reused? (list)))
   
   (printf "\tStore another directory\n")

   (define-values (dir-key-two dir-reused?)
      (store-directory! archive "test-data"))
   
   (assert dir-reused?)
   (assert (string=? dir-key dir-key-two))
   
   (printf "\tTag it (~A ~A)\n" dir-key  dir-reused?)
   (define sk1 (tag-snapshot! archive "Test" dir-key-two dir-reused? (list)))
   
   (printf "\tWalk the history\n")
   
   (define result
      (fold-history archive (archive-tag archive "Test")
         (lambda (snapshot-key snapshot acc)
            (cons snapshot acc))
         '()))
   (assert (match result
     (((('previous . sk1)
        ('mtime . _)
        ('contents . dir-key-two))
       (('mtime . _)
        ('contents . dir-key))) #t)
     (else #f)))
   
   ;(printf "\tTest fold-archive-node\n")
   ;
   ;(printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
   ;(printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
   ;(printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
   
   "This archive seems to work!")

(create-directory "./tmp/be5")

(define archive (open-archive '((storage fs "./tmp/be5")) #f #t))
(printf "archive on fs: ~A\n" (test-archive archive "./tmp/be5"))
(archive-close! archive)

(create-directory "./tmp/be6")

(define archive (open-archive '((storage log "./tmp/be6/log" "./tmp/be6/index" "./tmp/be6/tags")) #f #t))
(printf "archive on log: ~A\n" (test-archive archive "./tmp/be6"))
(archive-close! archive)

(create-directory "./tmp/be7")

(define archive (open-archive '((storage splitlog "./tmp/be7" "./tmp/be7" 10000)) #f #t))
(printf "archive on splitlog: ~A\n" (test-archive archive "./tmp/be7"))
(archive-close! archive)