* guile-wiredtiger; moving to ffi
@ 2015-08-04 21:04 Amirouche Boubekki
0 siblings, 0 replies; only message in thread
From: Amirouche Boubekki @ 2015-08-04 21:04 UTC (permalink / raw)
To: Guile User
[-- Attachment #1: Type: text/plain, Size: 3572 bytes --]
Héllo guilers,
Today I share with you the current version of guile-wiredtiger.
wiredtiger is similar to gdbm ie. a key/value store persisted to disk
with the following features:
- records are ordered by keys using the lexicographic order
- ACID with different semantics (speed vs consistency)
- column aware with index support
It's the storage engine of recent versions mongodb.
Wiredtiger documentation is good, I recommend it:
http://source.wiredtiger.com/
This is the second version of those bindings, I first did
the bindings using the C API for some reason. I end using
ffi which is not as difficult as I though thanks to nalaginrut and ijp
work.
I come up with a little `foreign` macro, to help me with
this work. It has two parts:
- the function pointer
- the lambda that wraps the call to the function pointer
to process input and output
```
;; Small syntax change to keep the `foreign` readable
(define* ((dynamic-link* shared-object) func-name)
(dynamic-func func-name shared-object))
;;; foreign macro
(define-syntax-rule (foreign
;; function pointer and signature
(ret function-pointer args ...)
;; foreign-function lambda wrapper
wrapper)
(let ((foreign-function (pointer->procedure ret
function-pointer
(list args ...))))
(lambda (. rest)
(apply wrapper (append (list foreign-function) rest)))))
```
It's not a tremendous change. It groups all the code that
binds a given function.
A small "hiccup" arise when the function pointer must be retrieved from
an argument passed to the final procedure.
Like it's the case in the following example:
```
(define (%connection-close connection) ;; XXX: we need connection here
(foreign
(int (connection-structure-close (connection-structure connection))
*pointer* *pointer*)
(lambda (foreign-function config)
(let* (;; XXX: prepare foreign-function arguments
;; ... some code is missing here
;; call the foreign function
(code (foreign-function (connection-handle connection)
%config)))
;; XXX: process returned `code`
(eq? code 0))))
;; XXX: define a procedure that easy to call
(define*-public (connection-close connection #:optional (config ""))
((%connection-close connection) config))
```
I attached guile-wiredtiger with a basic reference
documentation and a simple example command line tool
that can index text and search. Scoring is left as an
exercice ;)
Also, here is a package for guix
```
(define-public wiredtiger
(package
(name "python-wiredtiger")
(version "2.6.1")
(source (origin
(method url-fetch)
(uri (list (string-append
"http://source.wiredtiger.com/releases/wiredtiger-"
version ".tar.bz2")))
(sha256
(base32
"173gv4yqb47jdbrvn80fbcf94s5sqixag997rw1jhjakxkdiv5xl"))))
(inputs `(("linux-libre-headers" ,linux-libre-headers)
("python-2", python-2)))
(build-system gnu-build-system)
(home-page "http://wiredtiger.com/")
(synopsis "database engine")
(description "wiredtiger is a key value store that support ACID
transactions
and more")
(license license:gpl2+)))
```
Regards,
Amirouche
[-- Attachment #2: wiredtiger.scm --]
[-- Type: text/plain, Size: 31557 bytes --]
;; guile-wiredtiger.
;; Copyright © 2014-2015 Amirouche BOUBEKKI <amirouche@hypermove.net>
;; guile-wiredtiger is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 2 of the License, or
;; (at your option) or version 3.
;; guile-wiredtiger is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with guile-wiredtiger. If not, see <http://www.gnu.org/licenses/>
(define-module (wiredtiger))
(use-modules (srfi srfi-9)) ;; records
(use-modules (srfi srfi-9 gnu)) ;; set-field & set-fields
(use-modules (rnrs bytevectors))
(use-modules (ice-9 iconv)) ;; string->bytevector
(use-modules (ice-9 format))
(use-modules (ice-9 optargs)) ;; define*
(use-modules (ice-9 receive))
(use-modules (system foreign)) ;; ffi
;;;
;;; Packing
;;;
;;
;; Adapted from wiredtiger Python bindings
;;
;; packing helpers
(define (number->byte-list value)
;; this is the *inversed* 64 bit representation of value
(list
(logand 255 9000)
(logand 255 (ash 9000 -8))
(logand 255 (ash 9000 -16))
(logand 255 (ash 9000 -24))
(logand 255 (ash 9000 -32))
(logand 255 (ash 9000 -40))
(logand 255 (ash 9000 -48))
(logand 255 (ash 9000 -56))))
(define (string->byte-list string)
(bytevector->u8-list (string->bytevector string "utf-8")))
(define (find-end-of-mark bv mark i)
(if (= (bytevector-u8-ref bv i) mark)
(find-end-of-mark bv mark (+ i 1))
i))
(define (bytevector-copy source dest from-index at-index)
(if (= from-index (bytevector-length source))
dest
(begin
(bytevector-u8-set! dest at-index (bytevector-u8-ref source from-index))
(bytevector-copy source dest (+ from-index 1) (+ at-index 1)))))
(define (bytevector-take bv index)
(letrec ((%take% (lambda (current out)
(if (= current index)
out
(begin
(bytevector-u8-set! out current (bytevector-u8-ref bv current))
(%take% (+ current 1) out))))))
(%take% 0 (make-bytevector index))))
(define (bytevector-drop bv index)
(bytevector-copy bv (make-bytevector (- (bytevector-length bv) index)) index 0))
(define (long-long-bytevector x)
(let ((out (make-bytevector 8)))
(bytevector-u64-set! out 0 x (endianness big))
out))
(define* (bytevector-find bv v #:optional (offset 0))
(if (equal? (bytevector-u8-ref bv 0) v)
offset
(bytevector-find (bytevector-drop bv 1) v (+ offset 1))))
(define (bytevector-append bv others)
(if (null? others)
bv
(letrec* ((other (car others))
(out (make-bytevector (+ (bytevector-length bv) (bytevector-length other)))))
(bytevector-copy! bv 0 out 0 (bytevector-length bv))
(bytevector-copy! other 0 out (bytevector-length bv) (bytevector-length other))
(bytevector-append out (cdr others)))))
(define (char-in c seq)
(if (= (string-length seq) 0)
#f
(if (equal? c (string-ref seq 0))
#t
(char-in c (string-drop seq 1)))))
(define (one-if-zero x)
(if (eq? x 0) 1 x))
;;; integer packing & unpacking
;; Variable-length integer packing
;; need: up to 64 bits, both signed and unsigned
;; Try hard for small values (up to ~2 bytes), after that, just encode the
;; length in the first byte.
;; First byte | Next | |
;; byte | bytes| Min Value | Max Value
;; ------------+------+------------------------+--------------------------------
;; [00 00xxxx] | free | N/A | N/A
;; [00 01llll] | 8-l | -2^64 | -2^13 - 2^6
;; [00 1xxxxx] | 1 | -2^13 - 2^6 | -2^6 - 1
;; [01 xxxxxx] | 0 | -2^6 | -1
;; [10 xxxxxx] | 0 | 0 | 2^6 - 1
;; [11 0xxxxx] | 1 | 2^6 | 2^13 + 2^6 - 1
;; [11 10llll] | l | 2^14 + 2^7 | 2^64 - 1
;; [11 11xxxx] | free | N/A | N/A
(define neg-multi-marker #x10)
(define neg-2byte-marker #x20)
(define neg-1byte-marker #x40)
(define pos-1byte-marker #x80)
(define pos-2byte-marker #xc0)
(define pos-multi-marker #xe0)
(define neg-1byte-min (* -1 (integer-expt -2 6)))
(define neg-2byte-min (+ (integer-expt -2 13) neg-1byte-min))
(define pos-1byte-max (- (integer-expt 2 6) 1))
(define pos-2byte-max (+ (integer-expt 2 13) pos-1byte-max))
(define minus-bit (ash -1 64))
(define uint64-mask #xffffffffffffffff)
(define* (get-bits x start #:optional (end 0))
(ash (logand x (- (ash 1 start) 1)) (* -1 end)))
(define* (get-int bytes #:optional (value 0))
(if (null? bytes) value
(get-int (cdr bytes) (logior (ash value 8) (car bytes)))))
(define (pack-integer x)
(cond ((< x neg-2byte-min)
(letrec* ((bytes (number->byte-list (logand x uint64-mask)))
(length (list-index bytes 255))
(tail (reverse (list-head bytes length)))
(head (logior neg-multi-marker (get-bits (- 8 length) 4))))
(cons head tail)))
((< x neg-1byte-min)
(let ((x2 (- x neg-2byte-min)))
(list (logior neg-2byte-marker (get-bits x2 13 8)) (get-bits x2 8))))
((< x 0) (let ((x2 (- x neg-1byte-min)))
(list (logior neg-1byte-marker (get-bits x 6)))))
((<= x pos-1byte-max) (list (logior pos-1byte-marker (get-bits x 6))))
((<= x pos-2byte-max) (let ((x2 (- x (+ pos-2byte-max 1))))
(list (logior pos-2byte-marker (get-bits x2 13 8)) (get-bits x2 8))))
(else (letrec* ((bytes (number->byte-list (- x (+ 1 pos-2byte-max))))
(length (list-index bytes 0))
(tail (reverse (list-head bytes length)))
(head (logior pos-multi-marker (get-bits length 4))))
(cons head tail)))))
(define (unpack-integer bytes)
(let ((marker (car bytes)))
(cond ((< marker neg-2byte-marker)
(let ((sz (- 8 (get-bits marker 4))))
(values (logior (ash -1 (ash sz 3)) (get-int (list-head (list-tail bytes 1) sz))
(list-tail bytes (+ sz 1))))))
((< marker neg-1byte-marker)
(values (+ neg-2byte-min (logior (ash (get-bits marker 5) 8) (cadr bytes)))
(list-tail bytes 2)))
((< marker pos-1byte-marker)
(values (+ neg-1byte-min (get-bits marker 6)) (list-tail bytes 1)))
((< marker pos-2byte-marker) (values (get-bits marker 6) (list-tail bytes 1)))
((< marker pos-multi-marker)
(values (+ pos-1byte-max 1 (logior (ash (get-bits marker 5) 8)) (cadr bytes))
(list-tail bytes 2)))
(else (let ((sz (get-bits marker 4)))
(values (+ pos-2byte-max 1 (get-int (list-head (list-tail bytes 1) sz)))
(list-tail bytes (+ sz 1))))))))
;; pack and unpack implementation
(define (get-type fmt)
(let ((tfmt (string-ref fmt 0)))
(if (char-in tfmt ".@<>")
(values tfmt (string-drop fmt 1))
(values "." fmt))))
(define (parse-format fmt)
(if (string->number (string-take fmt 1))
(values (string-drop fmt 2) (string->number (string-take fmt 1)) (string-ref fmt 1))
(values (string-drop fmt 1) 0 (string-ref fmt 0))))
(define (unpack-integers bytes number out)
(if (equal? number 0)
(values bytes out)
(receive (value bytes) (unpack-integer bytes)
(unpack-integers bytes (- number 1) (cons value out)))))
(define (unpack-rec fmt bytes out)
(if (= (string-length fmt) 0)
out
(receive (fmt size char) (parse-format fmt)
(cond
;; variable length string
((equal? char #\S)
(letrec* ((end (list-index bytes 0))
(tail (list-tail bytes (+ end 1)))
(head (list-head bytes end))
(string (bytevector->string (list->u8vector head) "utf8")))
(unpack-rec fmt tail (cons string out))))
;; variable length bytevector
((equal? char #\u)
(receive (size bytes) (unpack-integer bytes)
(letrec* ((tail (list-tail bytes size))
(head (list-head bytes size)))
(unpack-rec fmt tail (cons (list->u8vector head) out)))))
(else ;; integral type
(receive (bytes out) (unpack-integers bytes (one-if-zero size) out)
(unpack-rec fmt bytes out)))))))
(define-public (unpack fmt bytes)
(if (bytevector? bytes)
(reverse (unpack-rec fmt (bytevector->u8-list bytes) '()))
(reverse (unpack-rec fmt bytes '()))))
(define (make-next fmt vs)
(letrec* ((size (string->number (string-take fmt 1)))
(char (string-ref fmt (if size 1 0)))
(out (string-drop fmt (if size 2 1))))
(values out (cdr vs) char (if size size 0) (car vs))))
(define (pack-integers-rec size vs out)
(if (= size 0)
(values out vs)
(let ((integer (pack-integer (car vs))))
(pack-integers-rec (- size 1) (cdr vs) (append out integer)))))
(define (pack-rec fmt vs out)
(if (= (string-length fmt) 0)
out
(receive (fmt vs char size value) (make-next fmt vs)
(cond
;; variable length string
((equal? char #\S)
(pack-rec fmt vs (append out (string->byte-list value) '(0))))
;; variable length bytevector
((equal? char #\u)
(pack-rec fmt vs (append out (pack-integer (bytevector-length value)) (bytevector->u8-list value))))
;; integral type
(else
(receive (out vs) (pack-integers-rec (one-if-zero size) (cons value vs) out)
(pack-rec fmt vs out)))))))
(define-public (pack fmt . vs)
(u8-list->bytevector (pack-rec fmt vs '())))
;;;
;;; Guile helpers
;;;
;;
;; macro to quickly define immutable records
;;
;; FIXME: Taken from Guile (maybe should be in (srfi srfi-99))
;; adapted to make it possible to declare record type like `<abc>' and keep
;; field accessor bracket free. record name *must* have brackets or everything
;; is broken
;;
;; Usage:
;;
;; (define-record-type <abc> field-one field-two)
;; (define zzz (make-abc 1 2))
;; (abc-field-one zzz) ;; => 1
;;
;; FIXME: maybe this is less useful than the immutable record of (srfi srfi-9 gnu)
;; I still use `set-field` and `set-fields`
;;
(define-syntax define-record-type*
(lambda (x)
(define (%id-name name) (string->symbol (string-drop (string-drop-right (symbol->string name) 1) 1)))
(define (id-name ctx name)
(datum->syntax ctx (%id-name (syntax->datum name))))
(define (id-append ctx . syms)
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
(syntax-case x ()
((_ rname field ...)
(and (identifier? #'rname) (and-map identifier? #'(field ...)))
(with-syntax ((cons (id-append #'rname #'make- (id-name #'rname #'rname)))
(pred (id-append #'rname (id-name #'rname #'rname) #'?))
((getter ...) (map (lambda (f)
(id-append f (id-name #'rname #'rname) #'- f))
#'(field ...))))
#'(define-record-type rname
(cons field ...)
pred
(field getter)
...))))))
;;; ffi helpers
(define *NULL* %null-pointer)
(define *pointer* '*)
;; This is small syntax change
(define* ((dynamic-link* shared-object) func-name)
(dynamic-func func-name shared-object))
;;; foreign macro
(define-syntax-rule (foreign
;; function pointer and signature
(ret function-pointer args ...)
;; foreign-function lambda wrapper
wrapper)
(let ((foreign-function (pointer->procedure ret
function-pointer
(list args ...))))
(lambda (. rest)
(apply wrapper (append (list foreign-function) rest)))))
;;: utils
(define (make constructor constructor-structure pointer size)
"Convert a POINTER to a structure of SIZE into a record
using CONSTRUCTOR and CONSTRUCTOR-STRUCTURE"
(let* ((pointer (make-pointer (array-ref pointer 0)))
(array (pointer->bytevector pointer size 0 'u64))
(structure (apply constructor-structure (map make-pointer (array->list array)))))
(constructor pointer structure)))
;;;
;;; wiredtiger bindings
;;;
(define wiredtiger (dynamic-link "libwiredtiger.so"))
(define wiredtiger* (dynamic-link* wiredtiger))
(define WT_NOTFOUND -31803)
;;
;; (wiredtiger-error-string code)
;;
(define* (%wiredtiger-string-error call)
(foreign
(*pointer* (wiredtiger* "wiredtiger_strerror") int)
(lambda (foreign-function code)
(let ((message (pointer->string (foreign-function code))))
(format #t "wiredtiger error while calling ~a: ~a" call message))
;; here we use (exit) instead of (error) which outputs a not very useful traceback
(exit -1))))
(define (wiredtiger-string-error call message)
((%wiredtiger-string-error call) message))
;;;
;;; Connection
;;;
(define-record-type* <connection> handle structure)
(set-record-type-printer! <connection>
(lambda (record port)
(format port
"<session 0x~x>"
(pointer-address (connection-handle record)))))
;; record holding structure pointers
(define-record-type* <connection-structure>
async-flush
async-new-op
close
reconfigure
get-home
configure-method
is-new
open-session
load-extension
add-data-source
add-collator
add-compressor
add-encryptor
add-extractor
get-extension-api)
(define-public connection-open
(foreign
(int (wiredtiger* "wiredtiger_open") *pointer* *pointer* *pointer* *pointer*)
(lambda (foreign-function home config)
(let* (;; init a double pointer
(pointer #u64(0))
(double-pointer (bytevector->pointer pointer))
;; convert arguments to c types
(%home (string->pointer home))
(%config (string->pointer config))
;; call the foreign function
;; FIXME: add support for error_handler
(code (foreign-function %home *NULL* %config double-pointer)))
(if (eq? code 0)
(make make-connection make-connection-structure pointer 15)
(let ((message (format #false "(wiredtiger-open ~s ~s)" home config)))
(wiredtiger-string-error message code)))))))
(define (%connection-close connection)
(foreign
(int (connection-structure-close (connection-structure connection)) *pointer* *pointer*)
(lambda (foreign-function config)
(let* (;; init a double pointer
(pointer #u64(0))
(double-pointer (bytevector->pointer pointer))
;; convert arguments to c types
(%config (string->pointer config))
;; call the foreign function
;; FIXME: add support for error_handler
(code (foreign-function (connection-handle connection) %config)))
(if (eq? code 0)
#true
(let ((message (format #false "(connection-close ~s ~s)" connection config)))
(wiredtiger-string-error message code)))))))
(define*-public (connection-close connection #:optional (config ""))
((%connection-close connection) config))
;;;
;;; Session
;;;
(define-record-type* <session> handle structure)
(set-record-type-printer! <session>
(lambda (record port)
(format port
"<session 0x~x>"
(pointer-address (session-handle record)))))
;; record holding structure pointers
(define-record-type* <session-structure>
connection
%app-private%
close
reconfigure
string-error
cursor-open
create
compact
drop
log-printf
rename
salvage
truncate
upgrade
verify
transaction-begin
transaction-commit
transaction-rollback
checkpoint
snapshot
transaction-pinned-range
transaction-sync)
(define (%session-string-error session)
(foreign
(int (session-structure-string-error (session-structure session)) *pointer* int)
(lambda (foreign-function code)
(format #true
"wiredtiger session error: ~a"
(pointer->string (make-pointer (foreign-function (session-handle session) code))))
(exit -1))))
(define-public (session-string-error session code)
((%session-string-error session) code))
(define (%session-open connection)
(foreign
(int (connection-structure-open-session (connection-structure connection)) *pointer* *pointer* *pointer* *pointer*)
(lambda (foreign-function config)
(let* (;; init a double pointer
(pointer #u64(0))
(double-pointer (bytevector->pointer pointer))
;; convert arguments to c types
(%config (string->pointer config))
;; call the foreign function
;; FIXME: add support for error_handler
(code (foreign-function (connection-handle connection) *NULL* %config double-pointer)))
(if (eq? code 0)
(make make-session make-session-structure pointer 22)
(let ((message (format #false "(session-open ~s ~s)" connection config)))
(wiredtiger-string-error message code)))))))
(define*-public (session-open connection #:optional (config ""))
((%session-open connection) config))
(define (%session-create session)
(foreign
(int (session-structure-create (session-structure session)) *pointer* *pointer* *pointer*)
(lambda (foreign-function name config)
(let* (;; convert arguments to c types
(%name (string->pointer name))
(%config (string->pointer config))
;; call the foreign function
(code (foreign-function (session-handle session) %name %config)))
(if (not (eq? code 0))
(let ((message (format #false "(session-create ~s ~s)" name config)))
(wiredtiger-string-error message code)))))))
(define-public (session-create session name config)
((%session-create session) name config))
(define (%session-close session)
(foreign
(int (session-structure-close (session-structure session)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (session-handle session))))
(if (not (eq? code 0))
(let ((message (format #false "(session-close ~s)")))
(wiredtiger-string-error message code)))))))
(define-public (session-close session)
((%session-close session)))
(define (%session-transaction-begin session)
(foreign
(int (session-structure-transaction-begin (session-structure session)) *pointer* *pointer*)
(lambda (foreign-function config)
(let* ((%config (string->pointer config))
;; call the foreign function
(code (foreign-function (session-handle session) %config)))
(if (eq? code 0)
#true
(let ((message (format #false "(session-transaction-begin ~s ~s)" session config)))
(wiredtiger-string-error message code)))))))
(define*-public (session-transaction-begin session #:optional (config ""))
((%session-transaction-begin session) config))
(define (%session-transaction-commit session)
(foreign
(int (session-structure-transaction-commit (session-structure session)) *pointer* *pointer*)
(lambda (foreign-function config)
(let* ((%config (string->pointer config))
;; call the foreign function
(code (foreign-function (session-handle session) %config)))
(if (eq? code 0)
#true
(let ((message (format #false "(session-transaction-commit ~s ~s)" session config)))
(wiredtiger-string-error message code)))))))
(define*-public (session-transaction-commit session #:optional (config ""))
((%session-transaction-commit session) config))
(define (%session-transaction-rollback session config)
(foreign
(int (session-structure-transaction-rollback (session-structure session)) *pointer* *pointer*)
(lambda (foreign-function name config)
(let* ((%config (string->pointer config))
;; call the foreign function
(code (foreign-function (session-handle session) %config)))
(if (eq? code 0)
#true
(let ((message (format #false "(session-transaction-rollback ~s)")))
(wiredtiger-string-error message code)))))))
(define*-public (session-transaction-rollback session #:optional (config ""))
((%session-transaction-rollback session) config))
;;;
;;; Item
;;;
(define-record-type* <item> handle bv)
(set-record-type-printer! <item>
(lambda (record port)
(format port
"<item 0x~x>"
(pointer-address (item-handle record)))))
;; record holding structure pointers
(define-record-type* <item-structure>
data
size
;; internal fields
flags
mem
mem-size
)
;;;
;;; Cursor
;;;
(define-record-type* <cursor> handle structure)
(set-record-type-printer! <cursor>
(lambda (record port)
(format port
"<cursor 0x~x>"
(pointer-address (cursor-handle record)))))
;; record holding structure pointers
(define-record-type* <cursor-structure>
cursor
uri
key-format
value-format
key-ref
value-ref
key-set
value-set
compare
equals
next
previous
reset
search
search-near
insert
update
remove
close
reconfigure
;; XXX: other fields are defined in the header
;; those are only useful to implement a new cursor type
;; and as such are not part the record
)
(define (%cursor-open session)
(foreign
(int (session-structure-cursor-open (session-structure session)) *pointer* *pointer* *pointer* *pointer* *pointer*)
(lambda (foreign-function uri config)
(let* (;; init a double pointer
(pointer #u64(0))
(double-pointer (bytevector->pointer pointer))
;; convert arguments to c types
(%uri (string->pointer uri))
(%config (string->pointer config))
;; call the foreign function
(code (foreign-function (session-handle session) %uri *NULL* %config double-pointer)))
(if (eq? code 0)
(make make-cursor make-cursor-structure pointer 20)
(let ((message (format #false "(cursor-open ~s ~s)" uri config)))
((wiredtiger-string-error message) code)))))))
(define-public (cursor-open session uri config)
((%cursor-open session) uri config))
(define (%cursor-key-ref cursor)
(foreign
(int (cursor-structure-key-ref (cursor-structure cursor)) *pointer* *pointer*)
(lambda (foreign-function)
(let* (;; init empty item structure
(item #u64(0 0 0 0 0))
(pointer (bytevector->pointer item))
;; call the foreign function
(code (foreign-function (cursor-handle cursor) pointer)))
(if (eq? code 0)
(pointer->bytevector (make-pointer (array-ref item 0))
(array-ref item 1)
0
'u64)
(let ((message (format #false "(cursor-key-ref ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-key-ref cursor)
((%cursor-key-ref cursor)))
(define (%cursor-value-ref cursor)
(foreign
(int (cursor-structure-value-ref (cursor-structure cursor)) *pointer* *pointer*)
(lambda (foreign-function)
(let* (;; init empty item structure
(item #u64(0 0 0 0 0))
(pointer (bytevector->pointer item))
;; call the foreign function
(code (foreign-function (cursor-handle cursor) pointer)))
(if (eq? code 0)
(pointer->bytevector (make-pointer (array-ref item 0))
(array-ref item 1)
0
'u64)
(let ((message (format #false "(cursor-value-ref ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-value-ref cursor)
((%cursor-value-ref cursor)))
(define (%cursor-key-set cursor)
(foreign
(int (cursor-structure-key-set (cursor-structure cursor)) *pointer* *pointer*)
(lambda (foreign-function bv)
(let* (;; init item structure
(bv* (bytevector->pointer bv))
(address (pointer-address bv*))
(size (bytevector-length bv))
(item (list->u64vector (list address size 0 0 0)))
(pointer (bytevector->pointer item)))
;; call the foreign function
(foreign-function (cursor-handle cursor) pointer)))))
(define-public (cursor-key-set cursor key)
((%cursor-key-set cursor) key))
(define (%cursor-value-set cursor)
(foreign
(int (cursor-structure-value-set (cursor-structure cursor)) *pointer* *pointer*)
(lambda (foreign-function bv)
(let* (;; init item structure
(bv* (bytevector->pointer bv))
(address (pointer-address bv*))
(size (bytevector-length bv))
(item (list->u64vector (list address size 0 0 0)))
(pointer (bytevector->pointer item)))
;; call the foreign function
(foreign-function (cursor-handle cursor) pointer)))))
(define-public (cursor-value-set cursor value)
((%cursor-value-set cursor) value))
(define (%cursor-reset cursor)
(foreign
(int (cursor-structure-reset (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(let ((message (format #false "(cursor-reset ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-reset cursor)
((%cursor-reset cursor)))
(define (%cursor-next cursor)
(foreign
(int (cursor-structure-next (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(if (eq? code WT_NOTFOUND)
#false
(let ((message (format #false "(cursor-next ~a)" cursor)))
(wiredtiger-string-error message code))))))))
(define-public (cursor-next cursor)
((%cursor-next cursor)))
(define (%cursor-previous cursor)
(foreign
(int (cursor-structure-previous (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(let ((message (format #false "(cursor-previous ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-previous cursor)
((%cursor-previous cursor)))
(define (%cursor-search cursor)
(foreign
(int (cursor-structure-search (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
#false)))))
(define-public (cursor-search cursor)
((%cursor-search cursor)))
(define (%cursor-search-near cursor)
(foreign
(int (cursor-structure-search-near (cursor-structure cursor)) *pointer* *pointer*)
(lambda (foreign-function)
(let* (;; init a integer pointer
(integer #u64(0))
(pointer (bytevector->pointer integer))
;; call the foreign function
(code (foreign-function (cursor-handle cursor) pointer)))
(if (eq? code 0)
(array-ref integer 0)
(if (eq? code WT_NOTFOUND)
#false
(let ((message (format #false "(cursor-search-near ~a)" cursor)))
(wiredtiger-string-error message code))))))))
(define-public (cursor-search-near cursor)
((%cursor-search-near cursor)))
(define (%cursor-insert cursor)
(foreign
(int (cursor-structure-insert (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(let ((message (format #false "(cursor-insert ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-insert cursor)
((%cursor-insert cursor)))
(define (%cursor-update cursor)
(foreign
(int (cursor-structure-update (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(let ((message (format #false "(cursor-update ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-update cursor)
((%cursor-update cursor)))
(define (%cursor-remove cursor)
(foreign
(int (cursor-structure-remove (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(let ((message (format #false "(cursor-remove ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-remove cursor)
((%cursor-remove cursor)))
(define (%cursor-close cursor)
(foreign
(int (cursor-structure-close (cursor-structure cursor)) *pointer*)
(lambda (foreign-function)
(let* (;; call the foreign function
(code (foreign-function (cursor-handle cursor))))
(if (eq? code 0)
#true
(let ((message (format #false "(cursor-close ~a)" cursor)))
(wiredtiger-string-error message code)))))))
(define-public (cursor-close cursor)
((%cursor-close cursor)))
;; ;;; e.g.
;; (define connection (pk (connection-open "/tmp/wt" "create")))
;; (define session (pk (session-open connection)))
;; ;; create a table
;; (session-create session "table:nodes" "key_format=S,value_format=i")
;; ;; open a cursor over than table
;; (define cursor (pk (cursor-open session "table:nodes" "raw")))
;; ;; start a transaction
;; (session-transaction-begin session "isolation=\"snapshot\"")
;; (cursor-key-set cursor (pack "i" 42))
;; (cursor-value-set cursor (pack "S" "The one true number!"))
;; (cursor-insert cursor)
;; (session-transaction-commit session)
;; (cursor-reset cursor)
;; (cursor-next cursor)
;; (pk (unpack "i" (cursor-key-ref cursor)))
;; (pk (unpack "S" (cursor-value-ref cursor)))
;; (cursor-close cursor)
;; (session-close session)
;; (connection-close connection)
[-- Attachment #3: wiredtiger.md --]
[-- Type: text/plain, Size: 13533 bytes --]
# guile-wiredtiger
*build your own database*
`version 2015-07-04)`
## (use-modules (wiredtiger))
```scheme
(define connection (pk (connection-open "/tmp/wt" "create")))
(define session (pk (session-open connection)))
;; create a table
(session-create session "table:nodes" "key_format=S,value_format=i")
;; open a cursor over than table
(define cursor (pk (cursor-open session "table:nodes" "raw")))
;; start a transaction
(session-transaction-begin session "isolation=\"snapshot\"")
(cursor-key-set cursor (pack "i" 42))
(cursor-value-set cursor (pack "S" "The one true number!"))
(cursor-insert cursor)
(session-transaction-commit session)
(cursor-reset cursor)
(cursor-next cursor)
(pk (unpack "i" (cursor-key-ref cursor)))
(pk (unpack "S" (cursor-value-ref cursor)))
(cursor-close cursor)
(session-close session)
(connection-close connection)
```
## Kesako wiredtiger?
At the very core, it's a configurable ordered key/value store, column aware,
with global transactions.
wiredtiger is a versatile database built by the engineers who created
Oracle Berkeley Database (formely known as Sleepycat Database and bsddb)
to be the best of its kind taking advantage of new hardwares.
It's not only a database. With wiredtiger you can build fine tuned
databases and competitive generic databases like mysql or mongodb.
## Installation
wiredtiger does **not** work on 32 bits architectures.
You need to install wiredtiger (tested with 2.6.1) with the usual
`./configure && make && make install` cli dance. If you prefer to
use git:
```
git clone https://github.com/wiredtiger/wiredtiger.git
```
You also need a recent version of GNU Guile (tested with 2.0.11). It's available
in most GNU/Linux distributions.
## Reference API
A lot of the API is available, what remains can be the subject of patches :)
The following documentation doesn't cover all of wiredtiger, it is best to have
a look at [wiredtiger manual](http://source.wiredtiger.com/2.6.1/index.html) too.
They are three objects in guile-wiredtiger:
- `<connection>` a repsent a particular connection to the wiredtiger engine. ACID
is not supported across several instance of `<connection>`.
- `<session>` has a `<connection>` as parent. It's not threadsafe.
- `<cursor>` has a `<session>` as parent.
`pack` and `unpack` utility procedures must be used with respectively `cursor-key-set`,
`cursor-value-set` and `cursor-key-ret`, `cursor-value-ret`. This is done like so right
now because I need to understand better the API. Maybe it won't be required in the future
to use `pack` and `unpack` directly.
Both `pack` and `unpack` of this function do not check for the validity of their arguments
as such it can fail in non-obvious way.
```
(pack fmt . args)) -> bytevector
```
`fmt` is a configuration string that must match the underlying key or value record
format. It only support integral types `bBhHiIlLqQr` and variable length strings
`S`. See [format types for more information](http://source.wiredtiger.com/2.6.1/schema.html#schema_format_types).
`args` must *match* `fmt`.
```
(unpack fmt bytevector)) -> list
```
`fmt` is a configuration string that must match the underlying record format. It only
support integral types `bBhHiIlLqQr` and variable length strings `S`. See
[format types](http://source.wiredtiger.com/2.6.1/schema.html#schema_format_types)
for more information.
## connection
### `connection-open home config) -> connection`
Open a connection to a database. Most applications will open a single connection
to a database. A connection can be shared among several threads. There is no support
ACID transactions between several connections.
Example:
```
(connection-open "./databases/magic-numbers" "create,cache_size=500M")
```
`home` the path to the database home directory. The path must exists.
See [Database Home Directory for more information]().
### `(connection-close connection [config]) -> boolean`
Close connection. Any open sessions will be closed. config optional argument,
that can be `leak_memory` to not free memory during close.
## session
### `(session-open connection [config]) -> <session>`
Open a session.
Example:
```
(session-open connection "isolation=snapshot")
```
`config` configures isolation level:
- `read-uncommited` transactions can see changes made by other transactions
before those transactions are committed. Dirty reads, non-repeatable reads
and phantoms are possible.
- `read-commited` transactions cannot see changes made by other transactions
before those transactions are committed. Dirty reads are not possible;
non-repeatable reads and phantoms are possible. Committed changes from
concurrent transactions become visible when no cursor is positioned in the
read-committed transaction.
- `snapshot` transactions read the versions of records committed before the
transaction started. Dirty reads and non-repeatable reads are not possible;
phantoms are possible.
### `(session-close session)`
Close the session handle. This will release the resources associated with the
session handle, including rolling back any active transactions and closing any
cursors that remain open in the session.
All data operations are performed in the context of a session. This encapsulates
the thread and transactional context of the operation.
Thread safety: A session is not usually shared between threads, see Multithreading
for more information.
### `(session-create session name config)`
Create a table, column group, index or file.
Example:
```
(session-create session "table:magic-numbers" "key_format=i,value_format=S")
```
`name` the URI of the object to create, such as `"table:stock"`. For a
description of URI formats see **Data Sources**.
`config` configures the object.
In guile-wiredtiger, `key_format` and `key_value` only support integral types
`bBhHiIlLqQr` and variable length strings `S`. See format types for more information.
### `(session-transaction-begin session [config])`
...
### `(session-transaction-commit session [config])`
Commit the current transaction. A transaction must be in progress when this
method is called. If sesssion-commit-transaction returns #f, the transaction
was rolled back, not committed.
### `(session-transaction-rollback session [config])`
Roll back the current transaction. A transaction must be in progress when this
method is called. All cursors are reset.
## cursor
### `(cursor-open session uri config) -> <cursor>`
Open a new cursor on a data source or duplicate an existing cursor.
An existing cursor can be duplicated by passing it as the `to_dup` parameter
and setting the uri parameter to `#nil`. Cursors being duplicated must have a
key set, and successfully duplicated cursors are positioned at the same place
in the data source as the original.
To reconfigure a cursor, duplicate it with a new configuration value
Cursor handles should be discarded by calling `cursor-close`.
Cursors capable of supporting transactional operations operate in the context
of the current transaction, if any.
`session-transaction-rollback` implicitly resets all cursors.
Cursors are relatively light-weight objects but may hold references to
heavier-weight objects; applications should re-use cursors when possible,
but instantiating new cursors is not so expensive that applications need
to cache cursors at all cost.
`uri` is the data source on which the cursor operates; cursors are usually
opened on tables, however, cursors can be opened on any data source,
regardless of whether it is ultimately stored in a table. Some cursor
types may have limited functionality (for example, they may be read-only
or not support transactional updates). See **Data Sources** for more information.
### `(cursor-key-set cursor bv)`
Set the key for the next operation. If an error occurs during this operation,
a flag will be set in the cursor, and the next operation to access the value
will fail. This simplifies error handling in applications.
`bv` is a 8bit bytevector that can be generated with pack. The bytevector must
consistent with the format of the current object key.
### `(cursor-value-set cursor bv)`
Set the key for the next operation. If an error occurs during this operation,
a flag will be set in the cursor, and the next operation to access the key will
fail. This simplifies error handling in applications.
`bv` is a 8bit bytevector that can be generated with pack. The bytevector must
consistent with the format of the current object value.
### `(cursor-key-ref cursor) -> bytevector`
Get the key for the current record. The returned value is a bytevector that can
be unpacked using the correct key format string of the associated object.
### `(cursor-value-ref cursor) -> bytevector`
Get the value for the current record. The returned value is a bytevector that can
be unpacked using the correct key format string of the associated object.
### `(cursor-next cursor) -> boolean`
Move the cursor to the next record. Returns #f if there is no more records.
### `(cursor-previous cursor) -> boolean`
Move the cursor to the previous record. Returns #f if there is no more records.
### `(cursor-reset cursor) -> boolean`
Reset the position of the cursor. Any resources held by the cursor are released,
and the cursor's key and position are no longer valid. A subsequent iteration
with `cursor-next` will move to the first record, or with `cursor-prev` will move
to the last record.
### `(cursor-search cursor) -> boolean`
On sucess move the cursor to the record matching the key. The key must first
be set.
To minimize cursor resources, the `cursor-reset` method should be called as soon
as the record has been retrieved and the cursor no longer needs that position.
### `(cursor-search-near cursor) -> -1, 0, 1 or #f`
Return the record matching the key if it exists, or an adjacent record.
An adjacent record is either the smallest record larger than the key or the largest
record smaller than the key (in other words, a logically adjacent key). The key must
first be set.
On success, the cursor ends positioned at the returned record; to minimize cursor
resources, the cursor-reset method should be called as soon as the record has been
retrieved and the cursor no longer needs that position.
### `(cursor-insert cursor) -> boolean`
Insert a record and optionally update an existing record.
If the cursor was configured with overwrite=true (the default), both the key and value
must be set; if the record already exists, the key's value will be updated, otherwise,
the record will be inserted.
If the cursor was configured with overwrite=false, both the key and value must be set
and the record must not already exist; the record will be inserted.
If a cursor with record number keys was configured with append=true (not the default),
the value must be set; a new record will be appended and the record number set as the
cursor key value.
The cursor ends with no position, and a subsequent call to the cursor-next
`cursor-prev` method will iterate from the beginning (end) of the table.
Inserting a new record after the current maximum record in a fixed-length bit field
column-store (that is, a store with an r type key and t type value) may implicitly
create the missing records as records with a value of 0.
When loading a large amount of data into a new object, using a cursor with the bulk
configuration string enabled and loading the data in sorted order will be much faster
than doing out-of-order inserts. See Bulk-load for more information.
The maximum length of a single column stored in a table is not fixed (as it partially
depends on the underlying file configuration), but is always a small number of bytes
less than 4GB.
### `(cursor-update cursor) -> boolean`
Update a record and optionally insert an existing record.
If the cursor was configured with overwrite=true (the default), both the key and value
must be set; if the record already exists, the key's value will be updated, otherwise,
the record will be inserted.
If the cursor was configured with overwrite=false, both the key and value must be set
and the record must already existe; the record will be updated.
On success, the cursor ends positioned at the modified record; to minimize cursor
resources, the cursor-reset method should be called as soon as the cursor no longer
needs that position.
The maximum length of a single column stored in a table is not fixed (as it partially
depends on the underlying file configuration), but is always a small number of bytes
less than 4GB.
### `(cursor-remove cursor) -> boolean`
Remove a record. The key must be set.
If the cursor was configured with overwrite=true (the default), the key must be set;
the key's record will be removed if it exists, no error will be returned if the record
does not exist.
If the cursor was configured with overwrite=false, the key must be set and the key's
record must exist; the record will be removed.
Removing a record in a fixed-length bit field column-store (that is, a store with an
r type key and t type value) is identical to setting the record's value to 0.
On success, the cursor ends positioned at the removed record; to minimize cursor resources,
the cursor-reset method should be called as soon as the cursor no longer needs that position.
### `(cursor-close cursor) -> boolean`
Close the cursor. This releases the resources associated with the cursor handle. Cursors
are closed implicitly by ending the enclosing connection or closing the session in which
they were opened.
[-- Attachment #4: haystack.scm --]
[-- Type: text/plain, Size: 6707 bytes --]
(define-module (haystack))
(use-modules (srfi srfi-1)) ;; fold
(use-modules (srfi srfi-9)) ;; records
(use-modules (srfi srfi-26)) ;; cut
(use-modules (ice-9 match)) ;; match
(use-modules (wiredtiger)) ;; key/value store
;;;
;;; Guile helpers
;;;
;;
;; macro to quickly define immutable records
;;
;; FIXME: Taken from Guile (maybe should be in (srfi srfi-99))
;; adapted to make it possible to declare record type like `<abc>' and keep
;; field accessor bracket free. record name *must* have brackets or everything
;; is broken
;;
;; Usage:
;;
;; (define-record-type <abc> field-one field-two)
;; (define zzz (make-abc 1 2))
;; (abc-field-one zzz) ;; => 1
;;
;; FIXME: maybe this is less useful than the immutable record of (srfi srfi-9 gnu)
;; I still use `set-field` and `set-fields`
;;
(define-syntax define-record-type*
(lambda (x)
(define (%id-name name) (string->symbol (string-drop (string-drop-right (symbol->string name) 1) 1)))
(define (id-name ctx name)
(datum->syntax ctx (%id-name (syntax->datum name))))
(define (id-append ctx . syms)
(datum->syntax ctx (apply symbol-append (map syntax->datum syms))))
(syntax-case x ()
((_ rname field ...)
(and (identifier? #'rname) (and-map identifier? #'(field ...)))
(with-syntax ((cons (id-append #'rname #'make- (id-name #'rname #'rname)))
(pred (id-append #'rname (id-name #'rname #'rname) #'?))
((getter ...) (map (lambda (f)
(id-append f (id-name #'rname #'rname) #'- f))
#'(field ...))))
#'(define-record-type rname
(cons field ...)
pred
(field getter)
...))))))
;;; database
(define-record-type* <database> connection session)
(define (connect)
(let* ((connection (connection-open "haystack.db" "create"))
(session (session-open connection)))
(session-create session "table:documents" "key_format=r,value_format=S")
(session-create session "table:grams" "key_format=Si,value_format=S")
(make-database connection session)))
(define (database-close database)
(session-close (database-session database))
(connection-close (database-connection database)))
;;; commands
(define (lst)
(let* ((database (connect))
(cursor (cursor-open (database-session database) "table:documents" "raw,")))
(let loop ()
(if (cursor-next cursor)
(begin
(format #true
"~a: ~a\n"
(car (unpack "r" (cursor-key-ref cursor)))
(car (unpack "S" (cursor-value-ref cursor))))
(loop))))
(database-close database)))
(define (%text->grams% text)
(define (word->grams word)
(let loop ((word word)
(grams '()))
(if (>= (string-length word) 3)
(loop (string-drop word 1) (cons (string-take word 3) grams))
;; do not index strings < 3
(reverse grams))))
(define words (filter (lambda (word) (not (equal? word ""))) (string-split text #\space)))
(fold (lambda (word grams) (append grams (word->grams word))) '() words))
(define (index title text)
(let* ((database (connect))
(documents (cursor-open (database-session database) "table:documents" "raw,append")))
;; insert new document
(cursor-value-set documents (pack "S" title))
(cursor-insert documents)
;; insert grams
(let ((grams (cursor-open (database-session database) "table:grams" "raw"))
(identifier (car (unpack "r" (cursor-key-ref documents)))))
(map (lambda (gram)
(cursor-key-set grams (pack "Si" gram identifier))
(cursor-value-set grams (pack "S" "ok"))
(cursor-insert grams))
(%text->grams% text))
;; cleanup
(cursor-close grams))
;; cleanup
(cursor-close documents)
(database-close database)))
(define (uniquify input)
"INPUT must be sorted list"
(let loop ((lst (cdr input))
(out (list (car input))))
(if (null? lst)
(reverse out)
(if (equal? (car lst) (car out))
(loop (cdr lst) out)
(loop (cdr lst) (cons (car lst) out))))))
(define (search keywords)
(let* ((database (connect))
(documents (cursor-open (database-session database) "table:documents" "raw"))
(grams (cursor-open (database-session database) "table:grams" "raw"))
;; retrieve identifiers of the records where the grams of keywords appear
(identifiers
(fold (lambda (gram identifiers)
(cursor-key-set grams (pack "S" gram))
(if (cursor-search-near grams)
(let loop ((identifiers identifiers))
(cursor-next grams)
(match (unpack "Si" (cursor-key-ref grams))
[(other identifier) (if (equal? gram other)
(loop (cons identifier identifiers))
identifiers)]))))
'()
(%text->grams% keywords)))
(identifiers (uniquify (sort identifiers <))))
(map (lambda (identifier)
(cursor-key-set documents (pack "i" identifier))
(cursor-search documents)
(format #true
"~a: ~a\n"
identifier
(car (unpack "S" (cursor-value-ref documents)))))
identifiers)
;; cleanup
(cursor-close grams)
(cursor-close documents)
(database-close database)))
(define (debug)
(let* ((database (connect))
(grams (cursor-open (database-session database) "table:grams" "raw")))
(let next ()
(if (cursor-next grams)
(begin
(format #true "index record (gram identifier): ~s\n" (unpack "Si" (cursor-key-ref grams)))
(next))))
(cursor-close grams)
(database-close database)))
(define (main args)
(match args
(("list") (lst))
(("index" title value) (index title value))
(("search" keywords) (search keywords))
(("debug") (debug))
(_ (begin (display "Welcome haystack.scm a tool that will allow you to index stuff using trigrams\n")
(newline)
(display "\tlist \t\t\tList everything in the index\n")
(display "\tindex TITLE VALUE\tAdd something to the index\n")
(display "\tsearch KEYWORDS\t\tSearch the index\n")
(display "\tdebug\t\t\tPrint the content of the index\n")))))
(main (cdr (command-line)))
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2015-08-04 21:04 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2015-08-04 21:04 guile-wiredtiger; moving to ffi Amirouche Boubekki
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).