(module lmdb

  (database-environment?
   current-database-environment
   open-database-environment close-database-environment
   copy-database-environment
   with-transaction
   database?
   open-database close-database drop-database

  [#:no-sync "MDB_NOSYNC"]
  [#:map-async "MDB_MAPASYNC"]
  [#:no-lock "MDB_NOLOCK"]
  [#:no-read-ahead "MDB_NORDAHEAD"])

(define-values (no-tls no-subdirectory)
  (values
   (foreign-value "MDB_NOTLS" unsigned-int)
   (foreign-value "MDB_NOSUBDIR" unsigned-int)))

(define (open-database-environment path . args)
  (let-keys+flags open-database-environment args
                  ([#:mode mode #o666]
                   [#:max-databases maxdbs #f]
                   [#:max-readers maxreaders #f]
                   [#:max-size mapsize #f])

  [#:reverse-duplicate "MDB_REVERSEDUP"]
  [#:create "MDB_CREATE"])

(define (open-database . args)
  (let-keys+flags open-database args
                  ([0 name #f])
                  ([database-flags flags])
    (let-location ([dbi database (wrap-database 0)])
      (check-error
       'open-database
       ((foreign-lambda
         int "mdb_dbi_open"
         nonnull-transaction c-string unsigned-int
         (nonnull-c-pointer database))
        (current-transaction) name flags (location dbi)))

  [#:no-overwrite "MDB_NOOVERWRITE"]
  [#:append "MDB_APPEND"]
  [#:append/duplicate "MDB_APPENDDUP"])

(define-values (database-ref database-set!)
  (letrec ([database-ref
            (lambda (dbi key #!optional [default (cut check-error 'database-ref not-found)])
              (let-location ([vlen size_t 0] [vptr c-pointer #f])
                (let ([status
                       ((foreign-lambda*
                         int ([nonnull-transaction txn] [database dbi]
                              [size_t klen] [scheme-pointer kptr]
                              [(c-pointer size_t) vlen] [(c-pointer c-pointer) vptr])
                         "int status;"
                         "MDB_val key, val;"
                         "key.mv_size = klen; key.mv_data = kptr;"
                         "val.mv_size = 0; val.mv_data = NULL;"
                         "status = mdb_get(txn, dbi, &key, &val);"
                         "*vlen = val.mv_size; *vptr = val.mv_data;"
                         "C_return(status);")
                        (current-transaction) dbi
                        (blob/string-size key) key
                        (location vlen) (location vptr))])
                  (cond
                    [(zero? status)

                   "key.mv_size = klen; key.mv_data = kptr;"
                   "val.mv_size = vlen; val.mv_data = vptr;"
                   "C_return(mdb_put(txn, dbi, &key, &val, flags));")
                  (current-transaction) dbi
                  (blob/string-size key) key
                  (blob/string-size val) val
                  flags))))])
    (values
     (getter-with-setter database-ref database-set!)
     database-set!)))

(define (database-exists? dbi key)
  (let ([status
         ((foreign-lambda*
           int ([nonnull-transaction txn] [database dbi]
                [size_t klen] [scheme-pointer kptr])
           "MDB_val key, val;"

     "key.mv_size = klen; key.mv_data = kptr;"
     "val.mv_size = vlen; val.mv_data = vptr;"
     "C_return(mdb_del(txn, dbi, &key, &val));")
    (current-transaction) dbi
    (blob/string-size key) key
    (blob/string-size val) val)))

;; Cursors

(define-foreign-tagged-type (cursor nonnull-cursor "MDB_cursor")
  cursor?
  tag:cursor)

(define close-cursor
  (foreign-lambda
   void "mdb_cursor_close"
   nonnull-cursor))

(define-values (cursor-set-range cursor-first cursor-next)
  (values
   (foreign-value "MDB_SET_RANGE" int)
   (foreign-value "MDB_FIRST" int)
   (foreign-value "MDB_NEXT" int)))

(define (database-fold proc seed dbi #!key from to< to<=)
  (let-location ([cursor cursor #f])
    (check-error
     'database-fold
     ((foreign-lambda
       int "mdb_cursor_open"
       nonnull-transaction database (c-pointer cursor))
      (current-transaction) dbi (location cursor)))
    (let ([complete? #f])
      (dynamic-wind
        (lambda ()
          (when complete?
            (error 'database-fold "cannot re-enter cursor walk")))
        (lambda ()
          (let loop ([op (if from cursor-set-range cursor-first)]
                     [key from] [seed seed])
            (let-location ([klen size_t 0] [kptr c-pointer #f]
                           [vlen size_t 0] [vptr c-pointer #f])
              (let ([status
                     ((foreign-lambda*
                       int ([nonnull-cursor cursor] [int op]
                            [size_t k0len] [scheme-pointer k0ptr]
                            [size_t k1len] [scheme-pointer k1ptr]
                            [int inclusive]
                            [(c-pointer size_t) klen] [(c-pointer c-pointer) kptr]
                            [(c-pointer size_t) vlen] [(c-pointer c-pointer) vptr])
                       "int status;"
                       "MDB_val key0, key1, val;"
                       "key0.mv_size = k0len; key0.mv_data = k0ptr;"
                       "key1.mv_size = k1len; key1.mv_data = k1ptr;"
                       "val.mv_size = 0; val.mv_data = NULL;"
                       "status = mdb_cursor_get(cursor, &key0, &val, op);"
                       "if (status == 0 && key1.mv_data != NULL) {"
                       "  if (mdb_cmp(mdb_cursor_txn(cursor), mdb_cursor_dbi(cursor), &key0, &key1) >= inclusive) status = MDB_NOTFOUND;"
                       "}"
                       "if (status == 0) {"
                       "  *klen = key0.mv_size; *kptr = key0.mv_data;"
                       "  *vlen = val.mv_size; *vptr = val.mv_data;"
                       "}"
                       "C_return(status);")
                      cursor op
                      (blob/string-size key) key
                      (blob/string-size (or to< to<=)) (or to< to<=)
                      (if to< 0 1)
                      (location klen) (location kptr)
                      (location vlen) (location vptr))])
                (cond
                  [(zero? status)
                   (let ([key (make-string klen)]
                         [val (make-string vlen)])
                     (move-memory! kptr key klen)
                     (move-memory! vptr val vlen)
                     (loop cursor-next key (proc key val seed)))]
                  [(eqv? status not-found)
                   seed]
                  [else
                   (check-error 'database-ref status)])))))
        (lambda ()
          ((foreign-lambda
            void "mdb_cursor_close"
            nonnull-cursor)
           cursor)
          (set! complete? #t))))))

(define (database-walk proc dbi . args)
  (apply
   database-fold
   (lambda (key val seed) (proc key val) seed) (void)
   dbi args))

)

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;