;;; macro
(define-syntax lookup-shared-value
  (syntax-rules ()
    ((lookup-shared-value %s)
     (shared-binding-ref
      (lookup-imported-binding %s)))))

;;; weak lists
(define (cons-weak obj list)
  (cons (make-weak-pointer obj) list))

(define (filter-collected list)
  (filter (lambda (weak-pointer)
            (not (weak-pointer-ref weak-pointer)))
          list))

;;; fluids
(define $current-env (make-fluid #f))
(define $current-db (make-fluid #f))
(define $current-transaction-id (make-fluid #f))

(define (current-env)
  (fluid $current-env))

(define (current-db)
  (fluid $current-db))

(define (current-transaction-id)
  (fluid $current-transaction-id))

(define (with-env db-env thunk)
  (let-fluid $current-env db-env thunk))

(define (with-db db thunk)
  (let-fluid $current-db db thunk))

(define (with-transaction options proc)
  (let-fluid        
     $current-transaction-id
     (bdb-begin-transaction options)
     (lambda ()
       (proc (lambda ()
	       (bdb-abort-transaction (current-transaction-id))))
       (bdb-commit-transaction (current-transaction-id)))))

;; constants
(define-finite-type bdb-flags :bdb-flags
  (id)
  bdb-flags-object?
  bdb-flags-elements
  bdb-flags-name
  bdb-flags-index
  (id bdb-flags-id)
  ((default 0)
   (rpc-client		(lookup-shared-value "scheme_DB_RPCCLIENT"))
   (join-env		(lookup-shared-value "scheme_DB_JOINENV"))
   (init-lock		(lookup-shared-value "scheme_DB_INIT_LOCK"))
   (init-log		(lookup-shared-value "scheme_DB_INIT_LOG"))
   (init-mpool		(lookup-shared-value "scheme_DB_INIT_MPOOL"))
   (init-replication	(lookup-shared-value "scheme_DB_INIT_REP"))
   (init-transactions	(lookup-shared-value "scheme_DB_INIT_TXN"))
   (run-recover		(lookup-shared-value "scheme_DB_RECOVER"))
   (recover-fatal	(lookup-shared-value "scheme_DB_RECOVER_FATAL"))
   (use-environ		(lookup-shared-value "scheme_DB_USE_ENVIRON"))
   (use-environ-root	(lookup-shared-value "scheme_DB_USE_ENVIRON_ROOT"))
   (create		(lookup-shared-value "scheme_DB_CREATE"))
   (lockdown		(lookup-shared-value "scheme_DB_LOCKDOWN"))
   (private		(lookup-shared-value "scheme_DB_PRIVATE"))
   (system-mem		(lookup-shared-value "scheme_DB_SYSTEM_MEM"))
   (thread		(lookup-shared-value "scheme_DB_THREAD"))
   (force		(lookup-shared-value "scheme_DB_FORCE"))
   (xa-create		(lookup-shared-value "scheme_DB_XA_CREATE"))
   (auto-commit		(lookup-shared-value "scheme_DB_AUTO_COMMIT"))
   (dirty-read		(lookup-shared-value "scheme_DB_DIRTY_READ"))
   (excl		(lookup-shared-value "scheme_DB_EXCL"))
   (nommap		(lookup-shared-value "scheme_DB_NOMMAP"))
   (rdonly		(lookup-shared-value "scheme_DB_RDONLY"))
   (thread		(lookup-shared-value "scheme_DB_SYSTEM_MEM"))
   (truncate		(lookup-shared-value "scheme_DB_TRUNCATE"))
   (nosync		(lookup-shared-value "scheme_DB_NOSYNC"))
   (consume		(lookup-shared-value "scheme_DB_CONSUME"))
   (consume-wait	(lookup-shared-value "scheme_DB_CONSUME_WAIT"))
   (get-both		(lookup-shared-value "scheme_DB_GET_BOTH"))
   (multiple		(lookup-shared-value "scheme_DB_MULTIPLE"))
   (rmw			(lookup-shared-value "scheme_DB_RMW"))
   (set-recno		(lookup-shared-value "scheme_DB_SET_RECNO"))
   (append		(lookup-shared-value "scheme_DB_APPEND"))
   (nodupdata		(lookup-shared-value "scheme_DB_NODUPDATA"))
   (nooverwrite		(lookup-shared-value "scheme_DB_NOOVERWRITE"))
   (current		(lookup-shared-value "scheme_DB_CURRENT"))
   (first		(lookup-shared-value "scheme_DB_FIRST"))
   (get-both		(lookup-shared-value "scheme_DB_GET_BOTH"))
   (writecursor		(lookup-shared-value "scheme_DB_WRITECURSOR"))
   (get-both-range	(lookup-shared-value "scheme_DB_GET_BOTH_RANGE"))
   (get-recno		(lookup-shared-value "scheme_DB_GET_RECNO"))
   (join-item		(lookup-shared-value "scheme_DB_JOIN_ITEM"))
   (last		(lookup-shared-value "scheme_DB_LAST"))
   (next		(lookup-shared-value "scheme_DB_NEXT"))
   (next-dup		(lookup-shared-value "scheme_DB_NEXT_DUP"))
   (next-nodup		(lookup-shared-value "scheme_DB_NEXT_NODUP"))
   (prev		(lookup-shared-value "scheme_DB_PREV"))
   (prev-nodup		(lookup-shared-value "scheme_DB_PREV_NODUP"))
   (set			(lookup-shared-value "scheme_DB_SET"))
   (set-range		(lookup-shared-value "scheme_DB_SET_RANGE"))
   (multiple-key	(lookup-shared-value "scheme_DB_MULTIPLE_KEY"))
   (txn-nosync		(lookup-shared-value "scheme_DB_TXN_NOSYNC"))
   (txn-nowait		(lookup-shared-value "scheme_DB_TXN_NOWAIT"))
   (txn-sync		(lookup-shared-value "scheme_DB_TXN_SYNC"))))

(define (fold-flags valid unit given)
  (fold-right
   (lambda (f flag)
     (if (member f valid)
	 (bitwise-ior (bdb-flags-id f) flag)
	 (raise (condition
		 (&bdb-invalid-flag (value given))))))
   (bdb-flags-id unit)
   (if (list? given) given (list given))))

(define (flag-one-of valid given)
  (cond
   ((null? given) 
    (bdb-flags-id (bdb-flags default)))
   ((member given valid)
    => (lambda (l)
	 (bdb-flags-id (car l))))
   (else
    (raise
     (condition
      (&bdb-invalid-flag (value given)))))))

(define-finite-type database-type :database-type
  (id)
  database-type-object?
  database-type-elements
  database-type-name
  database-type-index
  (id database-type-id)
  ((binary-tree		(lookup-shared-value "scheme_DB_BTREE"))
   (hash		(lookup-shared-value "scheme_DB_HASH"))
   (queue		(lookup-shared-value "scheme_DB_QUEUE"))
   (recno		(lookup-shared-value "scheme_DB_RECNO"))
   (unknown		(lookup-shared-value "scheme_DB_UNKNOWN"))))

;;; define error conditions
;;; with subconditions
(define-condition-type &bdb-error &condition
  bdb-error?)

;;; without subconditions

;; DB_LOCK_DEADLOCK
(define-condition-type &bdb-lock-deadlock &bdb-error
  bdb-lock-deadlock?)

;;DB_LOCK_NOTGRANTED
(define-condition-type &bdb-lock-not-granted &bdb-error
  bdb-lock-not-granted?)

;; DB_OLD_VERSION
(define-condition-type &bdb-old-db-version &bdb-error
  bdb-old-db-version?)

;; DB_REP_HANDLE_DEAD
(define-condition-type &bdb-db-handle-dead &bdb-error   
 bdb-db-handle-dead?)

;; DB_SECONDARY_BAD
(define-condition-type &bdb-secondary-index-bad &bdb-error
  bdb-secondary-index-bad?)

(define-condition-type &bdb-invalid-flag &bdb-error
  bdb-invalid-flag?)

(define raise-bdb-condition
  (let ((alist
         `((,-30995             ,&bdb-lock-deadlock)
           (,-30994               ,&bdb-lock-not-granted)
           (,-30989             ,&bdb-old-db-version)
           (,-30986           ,&bdb-db-handle-dead)
           (,-30977    , &bdb-secondary-index-bad))))
    (lambda (return-object)
      (cond 
       ((assoc return-object alist)
        => (lambda (p)
             (let ((the-condition (cadr p)))
	       (raise (condition (the-condition))))))
       (else 
        (raise 
         (condition (&bdb-error 
                     (code return-object)))))))))


;;; define bdb records
;;; DB handle : DB
(define-record-type bdb-db :bdb-db
  (make-bdb-db c-pointer)
  bdb-db?
  (c-pointer bdb-db-c-pointer))

(define-exported-binding "bdb-db" :bdb-db)

;;; DB environement handle : DB_ENV
(define-record-type bdb-env :bdb-env
  (make-bdb-env c-pointer weak-list)
  bdb-env?
  (c-pointer bdb-env-c-pointer)
  (weak-list bdb-env-weak-list set-bdb-env-weak-list!))

(define-exported-binding "bdb-env" :bdb-env)

(define (bdb-env-weak-list-add! session thing)
  (set-bdb-env-weak-list!
   session (cons-weak thing (bdb-env-weak-list session))))

(define (bdb-env-weak-list-filter! session)
  (set-bdb-env-weak-list!
   session (filter-collected (bdb-env-weak-list session))))

(define (bdb-env-finalizer-free session)
  (bdb-env-close session))

(define (bdb-env-finalizer session)
  (bdb-env-weak-list-filter! session)
  (if (null? (bdb-env-weak-list session))
      (add-finalizer! session bdb-env-finalizer-free)
      (add-finalizer! session bdb-env-finalizer)))

;;; DB memory poolfile : DB_MPOOLFILE
(define-record-type bdb-mpoolfile :bdb-mpoolfile
  (make-bdb-mpoolfile c-pointer)
  bdb-mpoolfile?
  (c-pointer bdb-mpoolfile-c-pointer))

(define-exported-binding "bdb-mpoolfile" :bdb-mpoolfile)

;;; DB transaction : DB_TXN
(define-record-type bdb-txn :bdb-txn
  (make-bdb-txn c-pointer)
  bdb-txn?
  (c-pointer bdb-txn-c-pointer))

(define-exported-binding "bdb-txn" :bdb-txn)

;;; DB Cursor : DBC
(define-record-type bdb-dbc :bdb-dbc
  (make-bdb-dbc c-pointer)
  bdb-dbc?
  (c-pointer bdb-dbc-c-pointer))

(define-exported-binding "bdb-dbc" :bdb-dbc)

(import-lambda-definition bdb-env-create-int (flags)
			  "scsh_bdb_env_create")

(define bdb-env-create
  (let ((valid-flags (list (bdb-flags rpc-client))))
    (lambda args
      (let-optionals args 
	  ((flags '()))
	(let ((handle 
	       (bdb-env-create-int (flag-one-of valid-flags flags))))
	  (if (integer? handle)
	      (raise-bdb-condition handle)
	      (begin
		(add-finalizer! handle bdb-env-close)
		handle)))))))

(import-lambda-definition 
    bdb-env-open-int 
  (env-handle db-home flags mode)
  "scsh_bdb_env_open")

(define bdb-env-open
  (let ((valid-flags 
	 (list (bdb-flags join-env) (bdb-flags init-lock)
	       (bdb-flags init-log) (bdb-flags init-mpool)
	       (bdb-flags init-replication) (bdb-flags init-transactions)
	       (bdb-flags run-recover) (bdb-flags recover-fatal))))
    (lambda (env-handle home-dir . args)
      (let-optionals args
	  ((flags '())
	   (mode 0))
	(let ((ret-object 
	       (bdb-env-open-int 
		env-handle home-dir 
		(fold-flags valid-flags (bdb-flags default) flags)
		mode)))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(import-lambda-definition 
    bdb-env-close-int 
  (env-handle flags)
  "scsh_bdb_env_close")

(define (bdb-env-close env-handle)
  (let ((ret-object 
	 (bdb-env-close-int env-handle (bdb-flags default))))
    (if (integer? ret-object)
	(raise-bdb-condition ret-object)
	ret-object)))

(import-lambda-definition 
    bdb-env-remove-int 
  (db-home flags)
  "scsh_bdb_env_remove")

;;; FIXME
; (define (bdb-env-remove env_handle db_home . args)
;   (let-optionals args
;       ((flags (bdb-flags DB_DEFAULT)))
;     (let* ((ret-object (bdb-env-remove-int env_handle db_home (bdb-flags-id flags))))
;       (if (integer? ret-object)
; 	  (raise-bdb-condition ret-object)
; 	  (begin
; 	    (values ret-object))))))

(import-lambda-definition 
    bdb-create-int 
  (env-handle flags) 
  "scsh_bdb_create")

(define (bdb-create . args)
  (let ((valid-flags (list (bdb-flags xa-create))))
    (let-optionals args
	((env (or (current-env) #f))
	 (flags '()))
      (let ((handle 
	     (bdb-create-int 
	      env 
	      (flag-one-of valid-flags flags))))
	(if (integer? handle)
	    (raise-bdb-condition handle)
	    (begin 
	      (add-finalizer! handle bdb-close)
	      handle))))))

(import-lambda-definition 
    bdb-open-int 
  (db-handle db-file database txnid type flags mode)
  "scsh_bdb_open")

(define bdb-open 
  (let ((valid-flags 
	 (list (bdb-flags auto-commit)(bdb-flags create)
	       (bdb-flags dirty-read) (bdb-flags excl)
	       (bdb-flags nommap) (bdb-flags rdonly)
	       (bdb-flags thread) (bdb-flags truncate))))
    (lambda (db-handle db-file . args)
      (let-optionals args
	  ((type (database-type binary-tree))
	   (flags '())
	   (mode 0)
	   (database (or (current-db) #f))
	   (txn-id (or (current-transaction-id) #f)))
	(let ((ret-object
	       (bdb-open-int db-handle db-file database txn-id
			     (database-type-id type)
			     (fold-flags valid-flags (bdb-flags default) flags)
			     mode)))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(import-lambda-definition 
    bdb-close-int 
  (db-handle flags) 
  "scsh_bdb_close")

(define bdb-close
  (let ((valid-flags (list (bdb-flags nosync))))
    (lambda (db-handle . args)
      (let-optionals args
	  ((flags '()))
	(let ((ret-object
	       (bdb-close-int 
		db-handle 
		(fold-flags valid-flags (bdb-flags default) flags))))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(import-lambda-definition 
    bdb-put-int 
  (db-handle key data txn-id flags)
  "scsh_bdb_put")

(define bdb-put
  (let ((valid-flags-0
	 (list (bdb-flags append) (bdb-flags nodupdata)
	       (bdb-flags nooverwrite)))
	(valid-flags-1 
	 (list (bdb-flags auto-commit))))
    (lambda (db-handle key data . args)
      (let-optionals args
	  ((txn-id (or (current-transaction-id) #f))
	   (flags-0 #f)
	   (flags-1 #f))
	(let* ((flags-0
		(if flags-0
		    (fold-flags valid-flags-0 (bdb-flags default) flags-0)
		    (bdb-flags-id (bdb-flags default))))
	       (flags-1
		(if flags-1
		    (fold-flags valid-flags-1 flags-0 flags-1)
		    (bdb-flags-id (bdb-flags default))))
	       (ret-object 
		(bdb-put-int db-handle key data txn-id flags-1)))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(import-lambda-definition 
    bdb-get-int 
  (db-handle key txn-id flags)
  "scsh_bdb_get")

(define bdb-get 
  (let ((valid-flags-0
	 (list (bdb-flags consume) (bdb-flags consume-wait)
	       (bdb-flags get-both) (bdb-flags set-recno)))
	(valid-flags-1 
	 (list (bdb-flags auto-commit) (bdb-flags multiple)
	       (bdb-flags rmw))))
    (lambda (db-handle key . args)
      (let-optionals args
	  ((txn-id (or (current-transaction-id) #f))
	   (flags-0 #f)
	   (flags-1 #f))
	(let* ((flags-0 
		(if flags-0
		    (fold-flags valid-flags-0 (bdb-flags default) flags-0)
		    (bdb-flags-id (bdb-flags default))))
	       (flags-1 
		(if flags-1
		    (fold-flags valid-flags-1 flags-0 flags-1)
		    (bdb-flags-id (bdb-flags default))))
	       (ret-object
		(bdb-get-int db-handle key txn-id flags-1)))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object) 
	      ret-object))))))

(import-lambda-definition 
    bdb-del-int 
  (db-handle key txn-id flags)
  "scsh_bdb_del")

(define bdb-del 
  (let ((valid-flags (list (bdb-flags auto-commit))))
    (lambda (db-handle key . args)
      (let-optionals args
	  ((txn-id (or (current-transaction-id) #f))
	   (flags '()))
	(let ((ret-object
	       (bdb-del-int db-handle key txn-id 
			    (flag-one-of valid-flags flags))))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(import-lambda-definition 
    bdb-truncate-int 
  (db-home txn-id flags)
  "scsh_bdb_truncate")

(define bdb-truncate
  (let ((valid-flags (list (bdb-flags auto-commit))))
    (lambda (db-handle . args)
      (let-optionals args
	  ((txn-id (or (current-transaction-id) #f))
	   (flags '()))
	(let ((ret-object
	       (bdb-truncate-int db-handle txn-id
				 (flag-one-of valid-flags flags))))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(import-lambda-definition 
    bdb-sync-int 
  (db-handle)
  "scsh_bdb_sync")

(define bdb-sync 
  (lambda (db-handle)
    (let ((ret-object (bdb-sync-int db-handle)))
      (if (integer? ret-object)
	  (raise-bdb-condition ret-object)
	  ret-object))))

(import-lambda-definition 
    bdb-create-cursor-int 
  (db-handle txn-id flags)
  "scsh_bdb_create_cursor")

;;; no need for finalizer since cursor is unitialized after return
; (define (bdb-create-cursor db_handle . args)
; (let-optionals args
; 		 ((txnid #f)
; 		  (flags (bdb-flags DB_DEFAULT)))
; 		  (let* ((ret-object(bdb-create-cursor-int db_handle txnid (bdb-flags-id flags))))
; 		    (if (integer? ret-object)(raise-bdb-condition ret-object) 
; 		       (begin (values ret-object))))))

(import-lambda-definition 
    bdb-cursor-cget-int 
  (db-handle flags)
  "scsh_bdb_cursor_cget")

; (define (bdb-cursor-cget dbc . args)
; (let-optionals args
; 		 ((flags (bdb-flags DB_DEFAULT)))
;                   (let* ((ret-object(bdb-cursor-cget-int dbc (bdb-flags-id flags))))
; 			 (if (integer? ret-object)(raise-bdb-condition ret-object) 
; 			     (begin (values ret-object))))))

(import-lambda-definition 
    bdb-txn-begin-int 
  (env-handle parent flags)
  "scsh_bdb_txn_begin")

(define bdb-begin-transaction
  (let ((valid-flags
	 (list (bdb-flags dirty-read) (bdb-flags txn-nosync)
	       (bdb-flags txn-nowait) (bdb-flags txn-sync))))
    (lambda (db-env . args)
      (let-optionals args
	  ((parent #f)
	   (flags #f))
	(let* ((flags 
		(if flags
		    (fold-flags valid-flags (bdb-flags default) flags)
		    (bdb-flags-id (bdb-flags default))))
	       (ret-object (bdb-txn-begin-int db-env parent flags)))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object) 
	      ret-object))))))

(import-lambda-definition 
    bdb-txn-abort-int (txn-id)
    "scsh_bdb_txn_abort")

(define (bdb-abort-transaction txn-id)
  (let ((ret-object (bdb-txn-abort-int txn-id)))
    (if (integer? ret-object)
	(raise-bdb-condition ret-object) 
	ret-object)))

(import-lambda-definition 
    bdb-txn-commit-int 
  (txn-id flags)
  "scsh_bdb_txn_commit")

(define bdb-commit-transaction
  (let ((valid-flags
	 (list (bdb-flags txn-nosync) (bdb-flags txn-sync))))
    (lambda (txn-id . args)
      (let-optionals args
	  ((flags '()))
	(let ((ret-object
	       (bdb-txn-commit-int txn-id (flag-one-of valid-flags flags))))
	  (if (integer? ret-object)
	      (raise-bdb-condition ret-object)
	      ret-object))))))

(define (string->byte-vector string)
  (let* ((length (string-length string))
	 (bv (make-byte-vector length 0)))
    (let lp ((index (- length 1)))
      (if (< index 0)
	  bv
	  (begin
	    (byte-vector-set! 
	     bv index (char->ascii (string-ref string index)))
	    (lp (- index 1)))))))

(define (byte-vector->string byte-vector)
  (let* ((length (byte-vector-length byte-vector))
	 (string (make-string length (ascii->char 0))))
    (let lp ((index (- length 1)))
      (if (< index 0)
	  string
	  (begin
	    (string-set! 
	     string index 
	     (ascii->char (byte-vector-ref byte-vector index)))
	    (lp (- index 1)))))))

(define (value->byte-vector thing)
  (let ((port (make-string-output-port)))
    (write thing port)
    (string->byte-vector 
     (string-output-port-output port))))

(define (byte-vector->value byte-vector)
  (let ((port (make-string-input-port
	       (byte-vector->string byte-vector))))
    (read port)))