(use ugarit-backend)
(use sql-de-lite)
(use srfi-4)
(use srfi-69)
(use srfi-13)
(use matchable)
(use regex)
(use miscmacros)

(define sql-schema
  (list
   "CREATE TABLE metadata (key TEXT PRIMARY KEY, value TEXT);"
   "INSERT INTO metadata VALUES ('version','1');"
   "CREATE TABLE blocks (key TEXT PRIMARY KEY, type TEXT, content BLOB, refcount INTEGER);"
   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))

(define (backend-sqlite dbpath)
   (let*
        ((*db*
          (let ((db (open-database dbpath)))
            (change-file-mode dbpath (bitwise-ior perm/irusr perm/iwusr)) ; Don't think we can do anything about the journal files, though.
            (set-busy-handler! db (busy-timeout 100000))
            (when (null? (schema db))
                  (for-each (lambda (statement)
                              (exec (sql db statement)))
                            sql-schema))
            (exec (sql db "BEGIN;"))
            db))

         ; Prepared statements
         (get-metadata-query (sql *db* "SELECT value FROM metadata WHERE key = ?"))
         (set-metadata-query (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES (?,?)"))
         (get-block-metadata-query (sql *db* "SELECT type FROM blocks WHERE key = ?"))
         (get-block-refcount-query (sql *db* "SELECT refcount FROM blocks WHERE key = ?"))
         (delete-block-query (sql *db* "DELETE FROM blocks WHERE key = ?"))
         (get-block-data-query (sql *db* "SELECT type, content FROM blocks WHERE key = ?"))
         (set-block-data-query (sql *db* "INSERT INTO blocks (key,type,content,refcount) VALUES (?,?,?,1)"))
         (link-block-query (sql *db* "UPDATE blocks SET refcount = refcount + 1 WHERE key = ?"))
         (unlink-block-query (sql *db* "UPDATE blocks SET refcount = refcount - 1 WHERE key = ?"))
         (get-tag-query (sql *db* "SELECT key FROM tags WHERE tag = ?"))
         (set-tag-query (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)"))
         (remove-tag-query (sql *db* "DELETE FROM tags WHERE tag = ?"))
         (set-tag-lock-query (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?"))
         (get-tag-lock-query (sql *db* "SELECT locked FROM tags WHERE tag = ?"))
         (get-tags-query (sql *db* "SELECT tag FROM tags"))

         ; Database access functions
         (get-metadata (lambda (key default)
                         (let ((result (query fetch get-metadata-query key)))
                           (if (null? result)
                               (begin
                                 (exec set-metadata-query key default)
                                 default)
                               (car result)))))
         (set-metadata! (lambda (key value)
                         (exec set-metadata-query key value)))

         ; Basic configurables
         (block-size (string->number (get-metadata "block-size" "1048576")))
         (writable? (not (string=? "0" (get-metadata "writable" "1"))))
         (check-writable (lambda ()
                           (unless writable?
                                   (error "This archive is write protected"))))

         ; Periodic commit management
         (commit-interval (string->number (get-metadata "commit-interval" "1000")))
         (*updates-since-last-commit* 0)
         (flush! (lambda ()
                   (when (> *updates-since-last-commit* 0)
                    (exec (sql *db* "COMMIT;"))
                    (exec (sql *db* "BEGIN;"))
                    (set! *updates-since-last-commit* 0))))
         (maybe-flush! (lambda ()
                         (inc! *updates-since-last-commit*)
                         (when (> *updates-since-last-commit* commit-interval)
                             (flush!))))

         ; Higher-level database utilities
         (get-block-data (lambda (key) ; Returns #f for nonexistant blocks
                           (let ((bd (query fetch get-block-data-query key)))
                             (if (pair? bd)
                                 (let ((type (string->symbol (first bd)))
                                       (content (blob->u8vector/shared (second bd))))
                                   (list type content))
                                 #f))))

         (get-block-metadata (lambda (key) ; Returns #f for nonexistant blocks
                           (let ((bd (query fetch get-block-metadata-query key)))
                             (if (pair? bd)
                                 (let ((type (string->symbol (first bd))))
                                   type)
                                 #f))))

         (set-block-data! (lambda (key type content)
                           (exec set-block-data-query key (symbol->string type) (u8vector->blob/shared content))
                           (maybe-flush!)))

         (link-block! (lambda (key)
                           (exec link-block-query key)
                           (maybe-flush!)))

         (unlink-block! (lambda (key)
                           (exec unlink-block-query key)
                           (maybe-flush!)
                           (let ((rc (query fetch get-block-refcount-query key)))
                             (if (pair? rc)
                                 (if (< (car rc) 1)
                                     (let ((contents (second (get-block-data key))))
                                       (exec delete-block-query key)
                                       contents)
                                     #f)
                                 #f))))

         (set-tag! (lambda (tag key)
                    (exec set-tag-query tag key)
                    (flush!)))

         (remove-tag! (lambda (tag)
                        (exec remove-tag-query tag)
                        (flush!)))

         (get-tag (lambda (tag)
                         (let ((td (query fetch get-tag-query tag)))
                           (if (pair? td)
                               (if (null? (car td)) ; treat NULL as no tag
                                   #f
                                   (car td))
                               #f))))

         (set-tag-lock! (lambda (tag lock)
                      (exec set-tag-lock-query lock tag)
                      (flush!)))

         (get-tag-lock (lambda (tag)
                         (let ((td (query fetch get-tag-lock-query tag)))
                           (if (pair? td)
                               (car td)
                               (begin ; Tag does not exist, create it on demand
                                 (set-tag! tag '()) ; insert NULL tag record
                                 0)))))

         (get-tags (lambda ()
                     (map car (query fetch-all get-tags-query)))))

      (make-storage
         block-size
         writable?
         #t ; We DO support unlink!

         (lambda (key data type) ; put!
           (check-writable)
           (when (get-block-metadata key)
                 (error "Duplicate block" key type))

           (set-block-data! key type data)
           (void))

         (lambda ()                     ; flush!
           (flush!)
           (void))

         (lambda (key) ; exists?
           (let ((bmd (get-block-metadata key)))
             bmd))

         (lambda (key) ; get
            (let* ((entry (get-block-data key)))
              (if (pair? entry)
               (let* ((type (first entry))
                      (content (second entry)))
                 content)
               #f)))

         (lambda (key) ; link!
           (check-writable)
           (link-block! key)
           (void))

         (lambda (key) ; unlink!
           (check-writable)
           (unlink-block! key))

         (lambda (tag key) ; set-tag!
           (check-writable)
           (set-tag! tag key)
           (void))

         (lambda (tag) ; tag
           (get-tag tag))

         (lambda () ; all-tags
           (get-tags))

         (lambda (tag) ; remove-tag!
           (check-writable)
           (remove-tag! tag)
           (void))

         (lambda (tag) ; lock-tag!
           (check-writable)
           (exec (sql *db* "COMMIT;"))
           (exec (sql *db* "BEGIN EXCLUSIVE;")) ; There can be ONLY ONE!
           (let ((existing-lock? (not (zero? (get-tag-lock tag)))))
             (if existing-lock?
                 (begin
                   #f)
                 (begin
                   (set-tag-lock! tag 1)
                   (flush!)
                   #t))))

         (lambda (tag) ; tag-locked?
           (if (zero? (get-tag-lock tag))
               #f
               #t))

         (lambda (tag) ; unlock-tag!
           (check-writable)
           (set-tag-lock! tag 0)
           (flush!))

         (lambda (command) ; admin!
           (match command
                  (('info)
                   (list (cons 'backend "sqlite")
                         (cons 'block-size block-size)
                         (cons 'writable? writable?)
                         (cons 'unlinkable? #t)
                         (cons 'file dbpath)
                         (cons 'commit-interval commit-interval)))
                  (('help)
                   (list (cons 'info "Return information about the archive")
                         (cons 'help "List available admin commands")
                         (cons 'stats "Examine the metadata and report back statistics")
                         (cons 'set-block-size! (sprintf "<size in bytes> Sets a new maximum block size (current: ~a)" block-size))
                         (cons 'set-commit-interval! (sprintf "<updates> Sets a new commit interval (current: ~a)" commit-interval))
                         (cons 'write-protect! (sprintf "Disable writing to the archive (currently ~a)" (if writable? "enabled" "disabled")))
                         (cons 'write-unprotect! (sprintf "Enable writing to the archive (currently ~a)" (if writable? "enabled" "disabled")))))
                  (('stats)
                   (let* ((stats (query fetch (sql *db* "SELECT COUNT(*), SUM(LENGTH(content)) FROM blocks"))))
                    (list (cons 'blocks (first stats))
                          (cons 'bytes (second stats)))))
                  (('set-block-size! size)
                   (assert (integer? size))
                   (set! block-size size)
                   (set-metadata! "block-size" (number->string size))
                   (list (cons 'result "Done")))
                  (('set-commit-interval! cis)
                   (assert (integer? cis))
                   (set! commit-interval cis)
                   (set-metadata! "commit-interval" (number->string  cis))
                   (list (cons 'result "Done")))
                  (('write-protect!)
                   (set! writable? #f)
                   (set-metadata! "writable" "0")
                   (list (cons 'result "Done")))
                  (('write-unprotect!)
                   (set! writable? #f)
                   (set-metadata! "writable" "1")
                   (list (cons 'result "Done")))
                  (else (error "Unknown admin command"))))
         (lambda () ; close!
           (flush!)
           (exec (sql *db* "COMMIT;"))
           (close-database *db*)))))

(define backend
  (match (command-line-arguments)
         ((base)
          (lambda () (backend-sqlite base)))

         (else
          (export-storage-error! "Invalid arguments to backend-sqlite")
          (printf "USAGE:\nbackend-sqlite <basedir-path>\n")
          #f)))

(if backend
    (export-storage! backend))