(lmdb): Add lmdb-range

7 files changed, 218 insertions, 30 deletions

diff --git a/Makefile.am b/Makefile.am
index 0947327..c6901d5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -38,7 +38,8 @@ SOURCES = lmdb.scm \
           lmdb/internal.scm \
           lmdb/low-level.scm
 
-TESTS = tests/lmdb/low-level.scm
+TESTS = tests/lmdb.scm \
+        tests/lmdb/low-level.scm
 
 TEST_EXTENSIONS = .scm
 SCM_LOG_DRIVER =                                \
diff --git a/guix.scm b/guix.scm
index 98622b3..eeefd1c 100644
--- a/guix.scm
+++ b/guix.scm
@@ -22,11 +22,12 @@
     ("automake" ,automake)
     ("pkg-config" ,pkg-config)
     ("texinfo" ,texinfo)))
- (inputs `(("guile" ,guile-3.0)
-           ("lmdb" ,lmdb)))
- (propagated-inputs `())
+ (inputs
+  `(("guile" ,guile-3.0)
+    ("lmdb" ,lmdb)))
+ (propagated-inputs
+  `(("guile-srfi-158" ,guile-srfi-158)))
  (synopsis "")
  (description "")
- (home-page
-  "https://inqlab.net/git/guile-lmdb.git")
+ (home-page "https://inqlab.net/git/guile-lmdb.git")
  (license license:gpl3+))
diff --git a/hall.scm b/hall.scm
index fcc7ccf..71c7b72 100644
--- a/hall.scm
+++ b/hall.scm
@@ -15,7 +15,8 @@
                              (scheme-file "low-level")))))
         (tests
          ((directory "tests"
-                     ((directory "lmdb" ((scheme-file "low-level")))))))
+                     ((scheme-file "lmdb")
+                      (directory "lmdb" ((scheme-file "low-level")))))))
         (programs ((directory "scripts" ())))
         (documentation
          ((org-file "README")
diff --git a/lmdb.scm b/lmdb.scm
index ebb3981..8495c8a 100644
--- a/lmdb.scm
+++ b/lmdb.scm
@@ -6,6 +6,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-158)
 
   #:use-module (rnrs io ports)
  
@@ -19,7 +20,12 @@
 
             <lmdb-db>
             lmdb-db?
-            lmdb-open))
+            lmdb-open
+            lmdb-close
+            lmdb-get
+            lmdb-put!
+            lmdb-delete!
+            lmdb-range))
 
 ;; Error handling
 
@@ -45,17 +51,30 @@
 
 (define* (lmdb-open path #:key db-name)
 
-  ;; create and open environment
+  ;; create environment
   (define env (mdb-env-create))
-  (mdb-env-open env path)
+  (unless (mdb-env? env)
+    (raise-lmdb-error env))
 
-  ;; create a transaction and open a database
+  ;; open environment
+  (define mdb-env-open-return-code (mdb-env-open env path))
+  (unless (eqv? MDB_SUCCESS mdb-env-open-return-code)
+    (raise-lmdb-error mdb-env-open-return-code))
+
+  ;; create a transaction
   (define txn (mdb-txn-begin env))
+  (unless (mdb-txn? txn)
+    (raise-lmdb-error txn))
+
+  ;; open a database
+  ;; TODO error handling
   (define dbi (mdb-dbi-open txn))
 
   ;; commit transaction so that database handle can now be used from other
   ;; transactions
-  (mdb-txn-commit txn)
+  (define mdb-txn-commit-return-code (mdb-txn-commit txn))
+  (unless (eqv? MDB_SUCCESS mdb-txn-commit-return-code)
+    (raise-lmdb-error mdb-txn-commit-return-code))
 
   (&make-lmdb-db env dbi #f))
 
@@ -103,5 +122,36 @@
      ((eqv? return-value MDB_NOTFOUND) #f)
      (else (raise-lmdb-error return-value)))))
 
-
-;; (lmdb-delete! db (string->utf8 "hi"))
+(define (lmdb-range db start-key end-key)
+  (let* ((txn (mdb-txn-begin (lmdb-db-env db)))
+         (cursor (mdb-cursor-open txn (lmdb-db-dbi db)))
+         ;; wrap start-key and end-key as mdb-val
+         (start-key-val (make-mdb-val start-key))
+         (end-key-val (make-mdb-val end-key))
+         ;; get an initial value with mdb-cursor-set
+         (init-value (mdb-cursor-set cursor start-key-val MDB_SET_RANGE)))
+    (make-coroutine-generator
+     (lambda (yield)
+       (let next ((return-value init-value))
+         (cond
+
+          ;; returned value is a key-value pair
+          ((pair? return-value)
+           ;; compare value with end-key and only yield if within range
+           (if (>= 0 (mdb-cmp txn (lmdb-db-dbi db) (car return-value) end-key-val))
+               (begin
+                 ;; yield key-value pair
+                 (yield (cons (mdb-val-data (car return-value))
+                              (mdb-val-data (cdr return-value))))
+                 ;; loop with next value
+                 (next (mdb-cursor-get cursor MDB_NEXT)))
+               (mdb-txn-abort txn)))
+
+          ;; no value found, end generator
+          ((equal? MDB_NOTFOUND return-value)
+           (mdb-txn-abort txn))
+
+          ;; unexpected return code, raise an error
+          ((integer? return-value)
+           (mdb-txn-abort txn)
+           (raise-lmdb-error return-value))))))))
diff --git a/lmdb/low-level.scm b/lmdb/low-level.scm
index 3bd1b19..7cb14d2 100644
--- a/lmdb/low-level.scm
+++ b/lmdb/low-level.scm
@@ -84,7 +84,9 @@
             MDB_PREV_NODUP
             MDB_SET
             MDB_SET_KEY
-            MDB_SET_RANGE))
+            MDB_SET_RANGE
+
+            mdb-cmp))
 
 ;; Return codes
 
@@ -396,24 +398,47 @@
 
 (define (mdb-cursor-set cursor key op)
   "Retrieve by cursor with MDB_SET* operation that requires a key to be specified"
-  (let ((proc (liblmdb-func "mdb_cursor_get"
+  (let* ((proc (liblmdb-func "mdb_cursor_get"
+                             (list
+                              ;; MDB_cursor* cursor
+                              '*
+                              ;; MDB_val* key
+                              '*
+                              ;; MDB_val* data
+                              '*
+                              ;; MDB_cursor_op op
+                              unsigned-int)))
+         ;; create a new pointer for returned data
+         (data-ptr (bytevector->pointer
+                    (make-bytevector (sizeof '*))))
+         ;; call mdb_cursor_get
+         (return-value (proc (unwrap-mdb-cursor cursor)
+                             (unwrap-mdb-val key)
+                             data-ptr
+                             op)))
+
+    (if (eqv? MDB_SUCCESS return-value)
+        ;; return key and data in order to have same API as mdb-cursort-get
+        (cons key (wrap-mdb-val data-ptr))
+        return-value)))
+
+;;
+
+(define (mdb-cmp txn dbi a b)
+  (let ((proc (liblmdb-func "mdb_cmp"
                             (list
-                             ;; MDB_cursor* cursor
-                             '*
-                             ;; MDB_val* key
+                             ;; MDB_txn* txn
                              '*
-                             ;; MDB_val* data
+                             ;; MDB_dbi dbi
+                             unsigned-int
+                             ;; const MDB_val* a
                              '*
-                             ;; MDB_cursor_op op
-                             unsigned-int)))
-        (data-ptr (bytevector->pointer
-                   (make-bytevector (sizeof '*)))))
-
-    ;; call mdb_cursor_get
-    (proc (unwrap-mdb-cursor cursor)
-          (unwrap-mdb-val key)
-          data-ptr
-          op)))
+                             ;; const MDB_val* b
+                             '*))))
+    (proc (unwrap-mdb-txn txn)
+          dbi
+          (unwrap-mdb-val a)
+          (unwrap-mdb-val b))))
 
 ;; (define env (mdb-env-create))
 
diff --git a/tests/lmdb.scm b/tests/lmdb.scm
new file mode 100644
index 0000000..c5b6259
--- /dev/null
+++ b/tests/lmdb.scm
@@ -0,0 +1,77 @@
+; SPDX-FileCopyrightText: 2021 pukkamustard <pukkamustard@posteo.net>
+;
+; SPDX-License-Identifier: GPL-3.0-or-later
+
+(define-module (tests lmdb)
+
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-64)
+  #:use-module (srfi srfi-158)
+  #:use-module (srfi srfi-171)
+
+  #:use-module (lmdb))
+
+(test-begin "Guile LMDB interface")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Setup
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Create a temporary directory
+(define db-dir "./tests/data/db")
+(system* "mkdir" "-p" db-dir)
+
+;; Open database
+(define db (lmdb-open db-dir))
+(test-assert (lmdb-db? db))
+
+;; no value for "Hello"
+(test-assert (not (lmdb-get db (string->utf8 "Hello"))))
+
+;; insert value for "Hello"
+(test-assert (lmdb-put! db (string->utf8 "Hello") (string->utf8 "LMDB!")))
+
+(test-equal "LMDB!"
+            (utf8->string (lmdb-get db (string->utf8 "Hello"))))
+
+;; delete key
+(test-assert (lmdb-delete! db (string->utf8 "Hello")))
+
+;; no value for "Hello"
+(test-assert (not (lmdb-get db (string->utf8 "Hello"))))
+
+;; Range
+
+;; add two ranges of entries
+(for-each (lambda (i)
+            (lmdb-put! db
+                       (u8-list->bytevector (list 0 i))
+                       (u8-list->bytevector (list i)))
+            (lmdb-put! db
+                       (u8-list->bytevector (list 1 i))
+                       (u8-list->bytevector (list i))))
+          (iota 32))
+
+;; TODO check that the correct ranges are returned
+(test-eqv 32 (generator-transduce
+              (tmap identity)
+              rcount
+              (lmdb-range db (make-bytevector 1 0) (make-bytevector 1 1))))
+
+(test-eqv 32 (generator-transduce
+              (tmap identity)
+              rcount
+              (lmdb-range db (make-bytevector 1 1) (make-bytevector 1 2))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Close DB and clean up
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; close the environment
+(lmdb-close db)
+
+;; clean up the directory
+(system (string-append "rm -rf " db-dir))
+
+(test-end "Guile LMDB interface")
diff --git a/tests/lmdb/low-level.scm b/tests/lmdb/low-level.scm
index 1a079e7..ae584f3 100644
--- a/tests/lmdb/low-level.scm
+++ b/tests/lmdb/low-level.scm
@@ -98,6 +98,38 @@
 ;; Abort transaction
 (mdb-txn-abort txn)
 
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compare values
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Begin a new transaction
+(define txn (mdb-txn-begin env))
+(test-assert (mdb-txn? txn))
+
+(test-eqv 0 (mdb-cmp txn dbi
+                     (make-mdb-val (u8-list->bytevector '(0)))
+                     (make-mdb-val (u8-list->bytevector '(0)))))
+
+(test-assert (> 0 (mdb-cmp txn dbi
+                           (make-mdb-val (u8-list->bytevector '(0)))
+                           (make-mdb-val (u8-list->bytevector '(1))))))
+
+(test-assert (> 0 (mdb-cmp txn dbi
+                           (make-mdb-val (u8-list->bytevector '(0)))
+                           (make-mdb-val (u8-list->bytevector '(0 1))))))
+
+(test-assert (< 0 (mdb-cmp txn dbi
+                           (make-mdb-val (u8-list->bytevector '(0 1)))
+                           (make-mdb-val (u8-list->bytevector '(0))))))
+
+(test-assert (< 0 (mdb-cmp txn dbi
+                           (make-mdb-val (u8-list->bytevector '(1)))
+                           (make-mdb-val (u8-list->bytevector '(0))))))
+
+;; Abort transaction
+(mdb-txn-abort txn)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Cursor
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -133,6 +165,7 @@
                       count
                       (next (1+ count))))))
 
+
 ;; Abort transaction
 (mdb-txn-abort txn)