#| -*-Scheme-*-
FFI for kyotocabinet (database)
|#

(declare (usual-integrations))
(load-option 'format)
(load-option 'ffi)
(C-include "kyotocabinet")

(define KCOREADER (C-enum "KCOREADER"))
(define KCOWRITER (C-enum "KCOWRITER"))
(define KCOCREATE (C-enum "KCOCREATE"))
(define KCOTRUNCATE (C-enum "KCOTRUNCATE"))
(define KCOAUTOTRAN (C-enum "KCOAUTOTRAN"))
(define KCOAUTOSYNC (C-enum "KCOAUTOSYNC"))
(define KCONOLOCK (C-enum "KCONOLOCK"))
(define KCOTRYLOCK (C-enum "KCOTRYLOCK"))
(define KCONOREPAIR (C-enum "KCONOREPAIR"))

(define KCESUCCESS (C-enum "KCESUCCESS"))
(define KCENOIMPL (C-enum "KCENOIMPL"))
(define KCEINVALID (C-enum "KCEINVALID"))
(define KCENOREPOS (C-enum "KCENOREPOS"))
(define KCENOPERM (C-enum "KCENOPERM"))
(define KCEBROKEN (C-enum "KCEBROKEN"))
(define KCEDUPREC (C-enum "KCEDUPREC"))
(define KCENOREC (C-enum "KCENOREC"))
(define KCELOGIC (C-enum "KCELOGIC"))
(define KCESYSTEM (C-enum "KCESYSTEM"))
(define KCEMISC (C-enum "KCEMISC"))

(define KCVISNOP (C-enum "KCVISNOP"))

(define (kcdbecode db)
  (C-call "kcdbecode" db))

(define (kcdbemsg db)
  (let ((res (make-alien '(* (const char)))))
    (C-call "kcdbemsg" res db)
    (c-peek-cstring res)))

(define (kcdbstatus db)
  (let ((res (make-alien '(* (const char)))))
    (C-call "kcdbstatus" res db)
    (c-peek-cstring res)))

(define (kcdbnew)
  (let ((db (make-alien '(* |KCDB|))))
    (C-call "kcdbnew" db)
    db))

(define (kcdbdel db)
  (C-call "kcdbdel" db))

(define (kcfree ptr)
  (C-call "kcfree" ptr))

(define (kcecodename code)
  (let ((res (make-alien '(* (const char)))))
    (C-call "kcdbemsg" res db)
    (c-peek-cstring res)))

(define (kctime)
  (C-call "kctime"))

(define (kcdbcount db)
  (C-call "kcdbcount" db))

(define (kcdbsize db)
  (C-call "kcdbsize" db))

(define (kcdbpath db)
  (let ((path (make-alien '(* char))))
    (C-call "kcdbpath" path db)
    (c-peek-cstring path)))

(define (kcdbopen db file flags)
  (let ((res (C-call "kcdbopen" db file flags)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbset db key value)
  (let ((res (C-call "kcdbset" db key (string-length key) value (string-length value))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbadd db key value)
  (let ((res (C-call "kcdbadd" db key (string-length key) value (string-length value))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbreplace db key value)
  (let ((res (C-call "kcdbreplace" db key (string-length key) value (string-length value))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbappend db key value)
  (let ((res (C-call "kcdbappend" db key (string-length key) value (string-length value))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbremove db key)
  (let ((res (C-call "kcdbremove" db key (string-length key))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbclear db)
  (let ((res (C-call "kcdbclear" db)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbsync db hard)
  (let ((res (C-call "kcdbsync" db (if hard 1 0) alien-null alien-null)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbcopy db dest)
  (let ((res (C-call "kcdbcopy" db dest)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbbegintran db hard)
  (let ((res (C-call "kcdbbegintran" db (if hard 1 0))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbbegintrantry db hard)
  (let ((res (C-call "kcdbbegintrantry" db (if hard 1 0))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbendtran db commit)
  (let ((res (C-call "kcdbendtran" db (if commit 1 0))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kcdbget db key)
  (let ((tgt (make-alien '(* char)))
        (sz (malloc 1 'int)))
    (C-call "kcdbget" tgt db key (string-length key) sz)
    (free sz)
    (if (alien-null? tgt)
        #f
        (c-peek-cstring tgt))))

(define (kcdbclose db)
  (C-call "kcdbclose" db))


(define (kcdbcursor db)
  (let ((res (make-alien '(* KCCUR))))
    (C-call "kcdbcursor" res db)
    res))

(define (kccurdel cur)
  (C-call "kccurdel" cur))

(define (kccursetvalue cur value step)
  (let ((res (C-call "kccursetvalue" cur value (string-length value) (if step 1 0))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kccurremove cur)
  (let ((res (C-call "kccurremove" cur)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kccurgetkey cur step)
  (let ((tgt (make-alien '(* char)))
        (sz (malloc 1 'int)))
    (C-call "kccurgetkey" tgt cur sz (if step 1 0))
    (free sz)
    (if (alien-null? tgt)
        #f
        (c-peek-cstring tgt))))

(define (kccurgetvalue cur step)
  (let ((tgt (make-alien '(* char)))
        (sz (malloc 1 'int)))
    (C-call "kccurgetvalue" tgt cur sz (if step 1 0))
    (free sz)
    (if (alien-null? tgt)
        #f
        (c-peek-cstring tgt))))

(define (kccurget cur step)
  (let ((key (malloc 1 '(* char)))
        (value (malloc 1 '(* (* char))))
        (key-size (malloc 1 'int))
        (value-size (malloc 1 'int)))
    (C-call "kccurget" key cur key-size value value-size (if step 1 0))
      (free key-size)
      (free value-size)
      (let ((key-str (if (alien-null? key) #f (c-peek-cstring key)))
            (value-str (if (alien-null? (c-> value "*")) #f (c-peek-cstring (c-> value "*")))))
        (kcfree key)
        (free value)
          (cons key-str value-str))))

(define (kccurjump cur)
  (let ((res (C-call "kccurjump" cur)))
    (if (= res 0)
        (if (= KCENOREC (kcdbecode db))
            #f
            (error (kcdbemsg db)))
        #t)))

(define (kccurjumpkey cur key)
  (let ((res (C-call "kccurjumpkey" cur key (string-length key))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kccurjumpback cur)
  (let ((res (C-call "kccurjumpback" cur)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kccurjumpbackkey cur key)
  (let ((res (C-call "kccurjumpbackkey" cur key (string-length key))))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kccurstep cur)
  (let ((res (C-call "kccurstep" cur)))
    (if (= res 0)
        (if (= (kcdbecode db) KCENOREC)
            #f
            (error (kcdbemsg db)))
        #t)))

(define (kccurstepback cur)
  (let ((res (C-call "kccurstepback" cur)))
    (if (= res 0)
        (error (kcdbemsg db))
        #t)))

(define (kccurdb cur)
  (let ((db (make-alien '(* KCDB))))
    (C-call "kccurdb" db cur)
    (if (alien-null? db)
        #f
        db)))

(define (kccurecode db)
  (C-call "kccurecode" db))

(define (kccuremsg db)
  (let ((res (make-alien '(* (const char)))))
    (C-call "kccuremsg" res db)
    (c-peek-cstring res)))

;; (define (walk-database db fun)
;;   (let ((cur (kcdbcursor db)))
;;     (let loop ((state (kccurjump cur)))
;;       (if state
;;           (let ((key+value (kccurget cur #f)))
;;             (fun (car key+value) (cdr key+value))
;;             (loop (kccurstep cur)))))))

(define (walk-database db fun)
  (if (= 0 (C-call "kcdbiterate"
          db
          (C-callback "kcvisitfull")
          (C-callback (lambda (key key-size value value-size sp)
                        (fun (substring (c-peek-cstring key) 0 key-size)
                             (substring (c-peek-cstring value) 0 value-size))
                        KCVISNOP))
          0))
         (error (kcdbemsg db))
         #t))

(define (test)
  (let ((db (kcdbnew)))
    (kcdbopen db "/tmp/test.kch" (+ KCOWRITER KCOCREATE))
    (kcdbclear db)
    (kcdbset db "foo" "bar")
    (kcdbset db "bar" "baaz")
    (format #t "time: ~a~%" (kctime))
    (format #t "size: ~a~%" (kcdbsize db))
    (format #t "path: ~a~%" (kcdbpath db))
    (format #t "count: ~a~%" (kcdbcount db))
    (format #t "read: ~a~%" (kcdbget db "bar"))
    (format #t "read: ~a~%" (kcdbget db "foo"))
    (format #t "read: ~a~%" (kcdbget db "baaz"))
    (format #t "add: ~a~%" (kcdbadd db "quux" "fart"))
                                        ;  (format #t "add: ~a~%" (kcdbadd db "quux" "fart"))
    (format #t "replace: ~a~%" (kcdbreplace db "quux" "bart"))
                                        ;  (format #t "replace: ~a~%" (kcdbreplace db "bart" "quux"))
    (format #t "append: ~a~%" (kcdbappend db "quux" " simpson"))
    (format #t "read: ~a~%" (kcdbget db "quux"))
    (format #t "remove: ~a~%" (kcdbremove db "quux"))
                                        ;  (format #t "remove: ~a~%" (kcdbremove db "quux"))
    (format #t "begin transaction: ~a~%" (kcdbbegintran db #t))
                                        ;  (format #t "begin transaction try: ~a~%" (kcdbbegintrantry db #t))
    (format #t "add: ~a~%" (kcdbadd db "lisa" "simpson"))
    (format #t "abort transaction: ~a~%" (kcdbendtran db #f))
    (format #t "get: ~a~%" (kcdbget db "lisa"))
    (format #t "begin transaction: ~a~%" (kcdbbegintran db #t))
                                        ;  (format #t "begin transaction try: ~a~%" (kcdbbegintrantry db #t))
    (format #t "add: ~a~%" (kcdbadd db "lisa" "simpson"))
    (format #t "end transaction: ~a~%" (kcdbendtran db #t))
    (format #t "get: ~a~%" (kcdbget db "lisa"))
    (let ((cur (kcdbcursor db)))
      (format #t "cursor jump: ~a~%" (kccurjump cur))
      (format #t "cursor key: ~a~%" (kccurgetkey cur #f))
      (format #t "cursor value: ~a~%" (kccurgetvalue cur #f)))
    (format #t "status: ~a~%" (kcdbstatus db))
    (format #t "walking database, contents:~%")
    (walk-database db (lambda (key value) (format #t "~a: ~a~%" key value)))
    (kcdbclear db)
    (kcdbclose db)
    (kcdbdel db)))